Uploaded bychriseidhof
KEY, PPTX982 views

Web programming in Haskell

The document discusses the current state of web programming using Haskell, highlighting the absence of a competitive framework and the potential for applying functional programming techniques. It introduces the Pesto framework, which consists of three libraries for data storage, display, and control flow, and provides a detailed description of various web functionalities such as quizzes, questions, and responses. The document outlines the coding structure, data types involved, and how users can interact with the quiz system.

Embed presentation

Download as KEY, PPTX
Web programming in Haskell Chris Eidhof
Current state of affairs • Web programming is done in dynamic languages • There is no competing Haskell framework • There are interesting FP techniques waiting to be applied
Using Haskell for web programming • Generic Programming • Type inferencing • Lenses • Type-level programming
The Pesto Framework Three libraries for programming the web • A library to store data • A library to display data • A library for control flow
Quiz Demo
The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions QuizModel Question) _email `for` lEmail questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil quizzes yet." $ F.enumRadio [(QA, choiceA q),(QB, choiceB $(deriveAll ''Quiz "PFQuiz") _ -> display (X.concatHtml . map quizWithLink) -< qs q),(QC, choiceC q)] $(deriveAll ''Question "PFQuestion") quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions Model code QuizModel Question) _email `for` lEmail questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil quizzes yet." $ F.enumRadio [(QA, choiceA q),(QB, choiceB $(deriveAll ''Quiz "PFQuiz") _ -> display (X.concatHtml . map quizWithLink) -< qs q),(QC, choiceC q)] $(deriveAll ''Question "PFQuestion") quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions Model code QuizModel Question) _email `for` lEmail questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil quizzes yet." $ F.enumRadio [(QA, choiceA q),(QB, choiceB $(deriveAll ''Quiz "PFQuiz") _ -> display (X.concatHtml . map quizWithLink) -< qs q),(QC, choiceC q)] $(deriveAll ''Question "PFQuestion") quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL URL handling quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions Model code QuizModel Question) _email `for` lEmail Controller + View questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil $(deriveAll ''Quiz "PFQuiz") $(deriveAll ''Question "PFQuestion") _ Controller + View quizzes yet." -> display (X.concatHtml . map quizWithLink) -< qs quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html $ F.enumRadio [(QA, choiceA q),(QB, choiceB q),(QC, choiceC q)] Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL URL handling quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions Model code QuizModel Question) _email `for` lEmail Controller + View questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil $(deriveAll ''Quiz "PFQuiz") $(deriveAll ''Question "PFQuestion") _ Controller + View quizzes yet." -> display (X.concatHtml . map quizWithLink) -< qs quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html $ F.enumRadio [(QA, choiceA q),(QB, choiceB q),(QC, choiceC q)] Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL URL handling quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q Miscellaneous templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
Adding a Quiz addQuiz :: Web () () addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
Adding a Quiz Input type addQuiz :: Web () () addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
Adding a Quiz Input type Output type addQuiz :: Web () () addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
Adding a Quiz Input type Output type Show a form addQuiz :: Web () () addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
Adding a Quiz Input type Output type Show a form addQuiz :: Web () () Store in the database addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
Adding a Quiz Input type Output type Show a form addQuiz :: Web () () Store in the database addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () Arrow inputs 1
Library 1 Web Interactions
Web interactions • Problem: HTTP is stateless • Solution: use continuations to model state
The Arc Challenge 1. Ask for a user’s name 2. Show a link “click here” 3. Display their name again
Solution arc :: Web () () arc = input &&& link "Click Here" >> display (λx → X.toHtml $ "Hello, " + fst x) > + 4
Solution (improved) arc = proc () → do name ← input () link "Click here" () display (λn → X.toHtml $ "Hello, " + n) + name 5
Web Interactions • Functional way to describe interactions • Type-safe way of combining them • Related: • Monadic interface
Library 2: Views Using generic programming to reduce boilerplate code
Generating HTML ghtml :: (Regular a, GHtml (PF a)) ⇒ a → X.Html data Quiz = Quiz{subject :: String , description :: String } Quiz system add quiz list quizzes Quiz Subject: What programming language are you? Description: This quiz is about what kind of programming language you are. view take quiz 6
Generating HTML ghtml :: (Regular a, GHtml (PF a)) ⇒ a → X.Html data Quiz = Quiz{subject :: String , description :: String } Quiz system add quiz list quizzes Quiz Subject: What programming language are you? Description: This quiz is about what kind of programming language you are. view take quiz 6
Generating HTML Sometimes the generated HTML needs to be changed
Generating HTML Sometimes the generated HTML needs to be changed Quiz system add quiz list quizzes data User = User{name :: String User , email :: String Name: chris , password :: String Email: chris@eidhof.nl } Password: haskell98 Continue
Solution: custom HTML • Error-prone • What if the input changes? • What if the HTML library changes?
Solution: change datatype data User = User{name :: String , email :: String , password :: NoHtml String } • Confuses view and model code • What if there are multiple views?
Solution: change datatype data User = User{name :: String , email :: String , password :: NoHtml String } • Confuses view and model code • What if there are multiple views?
Non Solution: change datatype data User = User{name :: String , email :: String , password :: NoHtml String } • Confuses view and model code • What if there are multiple views?
Solution: view datatypes userToUserView :: User → UserView userToUserView u = UserView (name u) (email u) data UserView = UserView{name :: String , email :: String } 10
Solution: view datatypes • We can keep using generic programming • Offer a lot of flexibility for removing, reordering and displaying of fields • We still allow manual HTML
Generating forms Sometimes the generated forms need to be changed
Generating forms Sometimes the generated forms need to be changed Quiz system add quiz list quizzes Name: Email: Date: Submit
Generating forms Sometimes the generated forms need to be changed Quiz system add quiz list quizzes Name: Email: Date: Submit Quiz system add quiz list quizzes subject: description: Larger! Submit
Generating forms Sometimes the generated forms need to be changed Quiz system Quiz system add quiz add quiz list quizzes list quizzes Name: name: Email: email: Date: Submit Submit Quiz system add quiz list quizzes subject: description: Larger! Submit
Generating forms Sometimes the generated forms need to be changed Quiz system Quiz system add quiz add quiz list quizzes list quizzes Name: name: Quiz system Email: email: add quiz list quizzes Date: Submit subject: Submit Quiz system description: add quiz list quizzes subject: description: Larger! Submit Submit
Generic Forms gform :: (Regular a, GFormlet (PF a)) ⇒ Maybe a → Form a 11
Generic Forms gform :: (Regular a, GFormlet (PF a)) ⇒ Maybe a → Form a userForm :: Maybe User → Form User userForm = gform 12
User Forms gform :: (Regular a, GFormlet (PF a)) ⇒ Maybe a → Form a userForm :: Maybe User → Form UserView userForm = gform ◦ fmap userToUserView 13
User Forms gform :: (Regular a, GFormlet (PF a)) ⇒ Maybe a → Form a userForm :: Maybe User → Form UserView userForm = gform ◦ fmap userToUserView How to convert to a User? 13
Solution: lenses convertUser :: User → UserView convertUser = Lens (UserView < > name ‘for‘ lName $ email ‘for‘ lEmail ) get convertUser :: (User → UserView) set convertUser :: (UserView → User → User) 13
Solution: lenses convertUser :: User → UserView convertUser = Lens (UserView < > name ‘for‘ lName $ email ‘for‘ lEmail ) Construct a view get convertUser :: (User → UserView) set convertUser :: (UserView → User → User) 13
Solution: lenses convertUser :: User → UserView convertUser = Lens (UserView < > name ‘for‘ lName $ email ‘for‘ lEmail ) Construct a view get convertUser :: (User → UserView) set convertUser :: (UserView → User → User) Update original with values from view 13
Solution: lenses projectedForm :: (a → b) → a → Form a userForm :: User → Form User userForm = projectedForm convertUser 14
Library 2: Summary • Using generic programming and view datatypes • Consistent UI • More applications: • API generation • API documentation
Library 3: Data Models
Current approaches • HaskellDB • Happstack’s data layer • HDBC • Sirenial • ...
First approach data Quiz = Quiz {subject :: String , description :: String , questions :: [Question] , responses :: [Response] } data Question = Question{title :: String , choiceA, choiceB, choiceC :: String , quiz :: Quiz } data Response = Response{name :: String , email :: Email , date :: Date , answers :: [Answer] , quiz :: Quiz } 15
First approach data Quiz = Quiz {subject :: String , description :: String , questions :: [Question] , responses :: [Response] } data Question = Question{title :: String , choiceA, choiceB, choiceC :: String , quiz :: Quiz } data Response = Response{name :: String , email :: Email , date :: Date , answers :: [Answer] , quiz :: Quiz } 15
First approach: problems • How to keep relationships in sync? • How to serialize?
Solution: entity relationship models Subject Name Description * 1 Date Response responses Quiz 1 Email questions Answers * ChoiceA Question ChoiceB ChoiceC Title
Solution: entity relationship models Attribute Subject Name Description * 1 Date Response responses Quiz 1 Email questions Answers * ChoiceA Question ChoiceB ChoiceC Title
Solution: entity relationship models Attribute Subject Name Description Entity * 1 Date Response responses Quiz 1 Email questions Answers * ChoiceA Question ChoiceB ChoiceC Title
Solution: entity relationship models Attribute Subject Name Description Entity * 1 Date Response responses Quiz 1 Email questions Answers Relationship * ChoiceA Question ChoiceB ChoiceC Title
ER models • Conceptual model • Compile to logical models: • In-memory database • Relational database • Diagrams • ...
ER models: constraints 1. Entities should have all the attributes 2. Cardinality is one-to-one, one-to-many, many-to-one, many-to-many 3. Relationships are only between entities in the same ER model 4. Relationships should be initialized when creating a new entity
Encoding entities data Quiz = Quiz{subject :: String , description :: String } Subject Description Quiz
Encoding entities data Quiz = Quiz{subject :: String , description :: String } Subject Description Quiz 1. Entities should have all the attributes
Encoding entities type QuizModel = Quiz :∗: Question :∗: Response :∗: Nil ixQuiz :: Ix QuizModel Quiz ixQuestion :: Ix QuizModel Question ixResponse :: Ix QuizModel Response 17
Encoding entities Type-level list type QuizModel = Quiz :∗: Question :∗: Response :∗: Nil ixQuiz :: Ix QuizModel Quiz ixQuestion :: Ix QuizModel Question ixResponse :: Ix QuizModel Response 17
Encoding entities Type-level list type QuizModel = Quiz :∗: Question :∗: Response :∗: Nil ixQuiz :: Ix QuizModel Quiz ixQuestion :: Ix QuizModel Question ixResponse :: Ix QuizModel Response Typed indexes 17
Encoding relationships 2. Cardinality is one-to-one, one-to-many, many-to-one, many-to-many 3. Relationships are only between entities in the same ER model
A first step Quiz data Rel cardL entityL cardR entityR where Rel :: Rel cardL entitityL cardR entityR 1 questions :: Rel QuizModel One Quiz Many Question questions questions = Rel * Question 18
A first step Cardinality Quiz data Rel cardL entityL cardR entityR where Rel :: Rel cardL entitityL cardR entityR 1 questions :: Rel QuizModel One Quiz Many Question questions questions = Rel * Question 18
Constraining cardinality data One data Many data Cardinality a where One :: Cardinality One Many :: Cardinality Many data Rel cardL entityL cardR entityR where Rel :: Cardinality cardinalityL → Cardinality cardinalityR → Rel cardinalityL l cardinalityR r 19
Constraining cardinality Type-level data One data Many data Cardinality a where One :: Cardinality One Many :: Cardinality Many data Rel cardL entityL cardR entityR where Rel :: Cardinality cardinalityL → Cardinality cardinalityR → Rel cardinalityL l cardinalityR r 19
Constraining cardinality Type-level data One data Many data Cardinality a where Value-level One :: Cardinality One Many :: Cardinality Many data Rel cardL entityL cardR entityR where Rel :: Cardinality cardinalityL → Cardinality cardinalityR → Rel cardinalityL l cardinalityR r 19
Constraining cardinality Type-level data One data Many data Cardinality a where Value-level One :: Cardinality One Many :: Cardinality Many data Rel cardL entityL cardR entityR where Rel :: Cardinality cardinalityL → Cardinality cardinalityR → Rel cardinalityL l cardinalityR r 2. Cardinality is one-to-one, one-to-many, many-to-one, many-to-many 19
Constraining entities Quiz data Rel entities cardinalityL l cardinalityR r where Rel :: Cardinality cardinalityL → Ix entities l 1 → Cardinality cardinalityR → Ix entities r → Rel entities cardinalityL l cardinalityR r questions questions :: Rel QuizModel One Quiz Many Question * questions = Rel One ixQuiz Many ixQuestion Question 20
Constraining entities List of all entities (type-level) Quiz data Rel entities cardinalityL l cardinalityR r where Rel :: Cardinality cardinalityL → Ix entities l 1 → Cardinality cardinalityR → Ix entities r → Rel entities cardinalityL l cardinalityR r questions questions :: Rel QuizModel One Quiz Many Question * questions = Rel One ixQuiz Many ixQuestion Question 20
Constraining entities List of all entities (type-level) Quiz data Rel entities cardinalityL l cardinalityR r where Rel :: Cardinality cardinalityL → Ix entities l Indexes into list 1 → Cardinality cardinalityR → Ix entities r → Rel entities cardinalityL l cardinalityR r questions questions :: Rel QuizModel One Quiz Many Question * questions = Rel One ixQuiz Many ixQuestion Question 20
Constraining entities List of all entities (type-level) Quiz data Rel entities cardinalityL l cardinalityR r where Rel :: Cardinality cardinalityL → Ix entities l Indexes into list 1 → Cardinality cardinalityR → Ix entities r → Rel entities cardinalityL l cardinalityR r questions questions :: Rel QuizModel One Quiz Many Question * questions = Rel One ixQuiz Many ixQuestion Question 3. Relationships are only between entities in the same ER model 20
What have we done? • Described entities • Described relationships • Guaranteed 3 out of 4 constraints
Encoding relationships 4. Relationships should be initialized when creating a new entity
Adding a Question Quiz new :: Ix entities entity → entity → PList entities entity (InitialValues entities entity rels rels) rels ? 1 → Basil entities rels (Ref entities entity) questions * Question 22
Adding a Question Quiz new :: Ix entities entity → entity → PList entities entity (InitialValues entities entity rels rels) rels 1 → Basil entities rels (Ref entities entity) questions * Question 22
Adding a Question Quiz new :: Ix entities entity → entity → PList entities entity (InitialValues entities entity rels rels) rels 1 → Basil entities rels (Ref entities entity) questions All to-one relationships involving * this entity Question 22
InitialValues function type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
InitialValues function List of all entities (type-level) type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
InitialValues function List of all entities (type-level) Current entity type type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
InitialValues function List of all entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
InitialValues function List of all entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
InitialValues function List of all entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
InitialValues function List of all entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
InitialValues function List of all entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 4. Relationships should be initialized when creating a new entity 23
ER model: encoding entities data Quiz = Quiz {subject :: String, description :: String} data Question = Question{title :: String, choiceA, choiceB, choiceC :: String} data Response = Response{name :: String , email :: Email , date :: Date , answers :: [Answer] } data Answer = QA | QB | QC type QuizModel = Quiz :∗: Question :∗: Response :∗: Nil 28
ER model: encoding relationships type Questions = Rel QuizModel One Quiz Many Question type Responses = Rel QuizModel One Quiz Many Response questions :: Questions questions = Rel One ixQuiz "quiz" Many ixQuestion "questions" responses :: Responses responses = Rel One ixQuiz "quiz" Many ixResponse "responses" type QuizRelations = Questions :∗: Responses :∗: Nil 29
ER model: wrap up • Enforcing constraints • In-memory backend • Relational backend • Query language
ER model: wrap up • Enforcing constraints • In-memory backend Same interface! • Relational backend • Query language
Conclusion • Three libraries: model, view, controller • A new start for Haskell web development • Notably missing: AJAX
Query language data Person = Person{name :: String, age :: Int} chris = Person "chris" 25 belowDrinkingAge :: Expr Person Bool belowDrinkingAge = age . < . Constant 18 isChris :: Expr Person Bool isChris = Not (belowDrinkingAge) .∧. name . ≡ . Constant "chris" In-memory database eval :: Expr entity a → (entity → a) toSql :: Expr entity a → String Relational database 25
In-memory database newtype TypeCache a = TypeCache{ cached :: M.Map Int a} deriving Show type Cache entities = HList (TMap TypeCache entities) type family RelationStorage rel :: ∗ type instance RelationStorage (Rel entities One r1 One r2) = M.Map (Ref entities r1) (Ref entities r2) type instance RelationStorage (Rel entities One r1 Many r2) = M.Map (Ref entities r2) (Ref entities r1) type instance RelationStorage (Rel entities Many r1 One r2) = M.Map (Ref entities r1) (Ref entities r2) type instance RelationStorage (Rel entities Many r1 Many r2) = (M.Map (Ref entities r1) (S.Set (Ref entities r2)) , M.Map (Ref entities r2) (S.Set (Ref entities r1))) 26
Relational Database type Table tables atts = HList2 (Attr tables) atts data TableT a = ∀env schema.TableT {unTableT :: Table env schema , trans :: a ⇔ HList schema } table :: (Regular a, GName (PF a), GSchema (PF a) schema) ⇒ a → TableT a class AddRelationship rels tables newTables | rels tables → newTables where addRelationships :: TList4 Rel rels → HList2 TableT tables → HList2 TableT newTables liftOperations :: TList4 Rel rels → Operation tables r → Operation newTables r 27

More Related Content

PDF
Spock and Geb
byChristian Baranowski
 
KEY
Jython: Python para la plataforma Java (EL2009)
byLeonardo Soto
 
PDF
Software architecture2008 ejbql-quickref
byjaiverlh
 
KEY
Jython: Python para la plataforma Java (JRSL 09)
byLeonardo Soto
 
PDF
Graph Connect: Importing data quickly and easily
byMark Needham
 
PDF
MongoDB Performance Tuning
byPuneet Behl
 
PPTX
Kamil Chmielewski, Jacek Juraszek - "Hadoop. W poszukiwaniu złotego młotka."
bysjabs
 
PDF
Hidden Treasures of the Python Standard Library
bydoughellmann
 
Spock and Geb
byChristian Baranowski
 
Jython: Python para la plataforma Java (EL2009)
byLeonardo Soto
 
Software architecture2008 ejbql-quickref
byjaiverlh
 
Jython: Python para la plataforma Java (JRSL 09)
byLeonardo Soto
 
Graph Connect: Importing data quickly and easily
byMark Needham
 
MongoDB Performance Tuning
byPuneet Behl
 
Kamil Chmielewski, Jacek Juraszek - "Hadoop. W poszukiwaniu złotego młotka."
bysjabs
 
Hidden Treasures of the Python Standard Library
bydoughellmann
 

What's hot

PPTX
Rapid and Scalable Development with MongoDB, PyMongo, and Ming
byRick Copeland
 
PDF
Php code for online quiz
byhnyb1002
 
PDF
Zend Framework 1 + Doctrine 2
byRalph Schindler
 
PDF
jQuery%20on%20Rails%20Presentation
byguestcf600a
 
PDF
Map/reduce, geospatial indexing, and other cool features (Kristina Chodorow)
byMongoSF
 
DOCX
WOTC_Import
byLuther Quinn
 
PDF
Kenneth Truyers - Using Git as a NoSql database - Codemotion Milan 2018
byCodemotion
 
PDF
Webtuesday Zurich
byDavid Nuescheler
 
PDF
Scala DSLの作り方
byTomoharu ASAMI
 
PDF
Aggregation Pipeline Power++: MongoDB 4.2 파이프 라인 쿼리, 업데이트 및 구체화된 뷰 소개 [MongoDB]
byMongoDB
 
PPTX
Webinar: Replication and Replica Sets
byMongoDB
 
PDF
はじめてのMongoDB
byTakahiro Inoue
 
PDF
7. arrays
by웅식 전
 
PDF
OSDC.fr 2012 :: Cascalog : progammation logique pour Hadoop
byPublicis Sapient Engineering
 
PDF
NoSQL для PostgreSQL: Jsquery — язык запросов
byCodeFest
 
PDF
The Testing Games: Mocking, yay!
byDonny Wals
 
ODP
PostgreSQL Moscow Meetup - September 2014 - Oleg Bartunov and Alexander Korotkov
byNikolay Samokhvalov
 
PPTX
PostgreSQL 9.4 JSON Types and Operators
byNicholas Kiraly
 
Rapid and Scalable Development with MongoDB, PyMongo, and Ming
byRick Copeland
 
Php code for online quiz
byhnyb1002
 
Zend Framework 1 + Doctrine 2
byRalph Schindler
 
jQuery%20on%20Rails%20Presentation
byguestcf600a
 
Map/reduce, geospatial indexing, and other cool features (Kristina Chodorow)
byMongoSF
 
WOTC_Import
byLuther Quinn
 
Kenneth Truyers - Using Git as a NoSql database - Codemotion Milan 2018
byCodemotion
 
Webtuesday Zurich
byDavid Nuescheler
 
Scala DSLの作り方
byTomoharu ASAMI
 
Aggregation Pipeline Power++: MongoDB 4.2 파이프 라인 쿼리, 업데이트 및 구체화된 뷰 소개 [MongoDB]
byMongoDB
 
Webinar: Replication and Replica Sets
byMongoDB
 
はじめてのMongoDB
byTakahiro Inoue
 
7. arrays
by웅식 전
 
OSDC.fr 2012 :: Cascalog : progammation logique pour Hadoop
byPublicis Sapient Engineering
 
NoSQL для PostgreSQL: Jsquery — язык запросов
byCodeFest
 
The Testing Games: Mocking, yay!
byDonny Wals
 
PostgreSQL Moscow Meetup - September 2014 - Oleg Bartunov and Alexander Korotkov
byNikolay Samokhvalov
 
PostgreSQL 9.4 JSON Types and Operators
byNicholas Kiraly
 

Viewers also liked

PDF
[WebCamp2014] Towards functional web
byBlaž Repas
 
PDF
From Ruby to Haskell (Kansai Yami RubyKaigi)
byujihisa
 
PDF
Haskell in the Real World
byosfameron
 
PPTX
Functional programming seminar (haskell)
byBikram Thapa
 
PDF
Building a website in Haskell coming from Node.js
byNicolas Hery
 
DOCX
Online movie ticket booking
bymrinnovater007
 
[WebCamp2014] Towards functional web
byBlaž Repas
 
From Ruby to Haskell (Kansai Yami RubyKaigi)
byujihisa
 
Haskell in the Real World
byosfameron
 
Functional programming seminar (haskell)
byBikram Thapa
 
Building a website in Haskell coming from Node.js
byNicolas Hery
 
Online movie ticket booking
bymrinnovater007
 

Similar to Web programming in Haskell

PDF
01. haskell introduction
bySebastian Rettig
 
KEY
Metaprogramming in Haskell
byHiromi Ishii
 
PDF
Introduction to Haskell@Open Source Conference 2007 Hokkaido
byikegami__
 
PDF
Managing complexity
bySmartLogic
 
PPTX
Haskell
byJackson dos Santos Olveira
 
KEY
QwalKeko, a History Querying Tool
bystevensreinout
 
PDF
Haskell - Being lazy with class
byTiago Babo
 
PDF
楽々Scalaプログラミング
byTomoharu ASAMI
 
01. haskell introduction
bySebastian Rettig
 
Metaprogramming in Haskell
byHiromi Ishii
 
Introduction to Haskell@Open Source Conference 2007 Hokkaido
byikegami__
 
Managing complexity
bySmartLogic
 
Haskell
byJackson dos Santos Olveira
 
QwalKeko, a History Querying Tool
bystevensreinout
 
Haskell - Being lazy with class
byTiago Babo
 
楽々Scalaプログラミング
byTomoharu ASAMI
 

More from chriseidhof

KEY
Cocoaheads app-in-4-weeks
bychriseidhof
 
PDF
Haskell for Scala-ists
bychriseidhof
 
KEY
Haskell for Scala-ists
bychriseidhof
 
PDF
HN NL - Haskell
bychriseidhof
 
PDF
Hackersnl
bychriseidhof
 
PDF
Functional Programming
bychriseidhof
 
Cocoaheads app-in-4-weeks
bychriseidhof
 
Haskell for Scala-ists
bychriseidhof
 
Haskell for Scala-ists
bychriseidhof
 
HN NL - Haskell
bychriseidhof
 
Hackersnl
bychriseidhof
 
Functional Programming
bychriseidhof
 

Recently uploaded

PPTX
Support, Monitoring, Continuous Improvement & Scaling Agentic Automation [3/3]
byUiPathCommunity
 
PDF
SELinux Policy Management in RHEL - RHCSA+.pdf
byLinuxCert Guru
 
PDF
AWS Cloud Technical Essentials - AWS Certificate
byVICTOR MAESTRE RAMIREZ
 
PPTX
Osmosis webinar presentation Nov 2025:Empowering UK Nursing Education
byJisc
 
PDF
Introduction to Shell Scripting - RHCSA+.pdf
byLinuxCert Guru
 
PDF
IDSECCONF2025 - Budi Rahardjo - Cyber Security and AI.pdf
byidsecconf
 
PDF
Mutation Testing for Industrial Robotic Systems (FMAS 2025)
bySylvain Hallé
 
PDF
Building a Multi-Tenant OpenShift Platform with HyperShift
byTosin Akinosho
 
PDF
THE THREATS OF INSTABILITY IN BRAZIL'S INTERCONNECTED ELECTRICAL SYSTEM AND H...
byFaga1939
 
PPTX
Opening Plenary - Esri UK Welsh Conference 2025
byEsri UK
 
PPTX
Redcentric Data Centres: vision, mission and values
byRedcentric
 
PDF
Building Powerful Web Apps to Improve Productivity and Engagement - Esri UK W...
byEsri UK
 
PPTX
Closing Plenary - Esri UK Welsh Conference 2025
byEsri UK
 
PDF
November 2025 OpenMetadata Community Spotlight - Astronomer & Airflow 3
byOpenMetadata
 
PDF
IDSECCONF2025 - Rama Tri Nanda - Hunting Stingray GSM on Budget.pdf
byidsecconf
 
PPTX
Conserving precious peatland habitats using mobile apps - Esri UK Welsh Confe...
byEsri UK
 
PDF
IDSECCONF2025 - Ali - DursGo–Web Security Scanner with AI Analysis.pdf
byidsecconf
 
PDF
Mastering Handlers, Conditions, and Loops in Ansible Playbooks - RHCE.pdf
byLinuxCert Guru
 
PDF
Build an AI/ML-driven image archive processing workflow: Image archive, analy...
bywesley chun
 
PDF
Infuse Intelligence Into your App with Foundry Local
byNilesh Gule
 
Support, Monitoring, Continuous Improvement & Scaling Agentic Automation [3/3]
byUiPathCommunity
 
SELinux Policy Management in RHEL - RHCSA+.pdf
byLinuxCert Guru
 
AWS Cloud Technical Essentials - AWS Certificate
byVICTOR MAESTRE RAMIREZ
 
Osmosis webinar presentation Nov 2025:Empowering UK Nursing Education
byJisc
 
Introduction to Shell Scripting - RHCSA+.pdf
byLinuxCert Guru
 
IDSECCONF2025 - Budi Rahardjo - Cyber Security and AI.pdf
byidsecconf
 
Mutation Testing for Industrial Robotic Systems (FMAS 2025)
bySylvain Hallé
 
Building a Multi-Tenant OpenShift Platform with HyperShift
byTosin Akinosho
 
THE THREATS OF INSTABILITY IN BRAZIL'S INTERCONNECTED ELECTRICAL SYSTEM AND H...
byFaga1939
 
Opening Plenary - Esri UK Welsh Conference 2025
byEsri UK
 
Redcentric Data Centres: vision, mission and values
byRedcentric
 
Building Powerful Web Apps to Improve Productivity and Engagement - Esri UK W...
byEsri UK
 
Closing Plenary - Esri UK Welsh Conference 2025
byEsri UK
 
November 2025 OpenMetadata Community Spotlight - Astronomer & Airflow 3
byOpenMetadata
 
IDSECCONF2025 - Rama Tri Nanda - Hunting Stingray GSM on Budget.pdf
byidsecconf
 
Conserving precious peatland habitats using mobile apps - Esri UK Welsh Confe...
byEsri UK
 
IDSECCONF2025 - Ali - DursGo–Web Security Scanner with AI Analysis.pdf
byidsecconf
 
Mastering Handlers, Conditions, and Loops in Ansible Playbooks - RHCE.pdf
byLinuxCert Guru
 
Build an AI/ML-driven image archive processing workflow: Image archive, analy...
bywesley chun
 
Infuse Intelligence Into your App with Foundry Local
byNilesh Gule
 

Web programming in Haskell

  • 1.
    Web programming inHaskell Chris Eidhof
  • 2.
    Current state ofaffairs • Web programming is done in dynamic languages • There is no competing Haskell framework • There are interesting FP techniques waiting to be applied
  • 3.
    Using Haskell forweb programming • Generic Programming • Type inferencing • Lenses • Type-level programming
  • 4.
    The Pesto Framework Threelibraries for programming the web • A library to store data • A library to display data • A library for control flow
  • 5.
  • 6.
    The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions QuizModel Question) _email `for` lEmail questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil quizzes yet." $ F.enumRadio [(QA, choiceA q),(QB, choiceB $(deriveAll ''Quiz "PFQuiz") _ -> display (X.concatHtml . map quizWithLink) -< qs q),(QC, choiceC q)] $(deriveAll ''Question "PFQuestion") quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
  • 7.
    The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions Model code QuizModel Question) _email `for` lEmail questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil quizzes yet." $ F.enumRadio [(QA, choiceA q),(QB, choiceB $(deriveAll ''Quiz "PFQuiz") _ -> display (X.concatHtml . map quizWithLink) -< qs q),(QC, choiceC q)] $(deriveAll ''Question "PFQuestion") quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
  • 8.
    The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions Model code QuizModel Question) _email `for` lEmail questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil quizzes yet." $ F.enumRadio [(QA, choiceA q),(QB, choiceB $(deriveAll ''Quiz "PFQuiz") _ -> display (X.concatHtml . map quizWithLink) -< qs q),(QC, choiceC q)] $(deriveAll ''Question "PFQuestion") quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL URL handling quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
  • 9.
    The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions Model code QuizModel Question) _email `for` lEmail Controller + View questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil $(deriveAll ''Quiz "PFQuiz") $(deriveAll ''Question "PFQuestion") _ Controller + View quizzes yet." -> display (X.concatHtml . map quizWithLink) -< qs quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html $ F.enumRadio [(QA, choiceA q),(QB, choiceB q),(QC, choiceC q)] Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL URL handling quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
  • 10.
    The Quiz Code takeQuiz :: Web (Ref QuizModel Quiz) () takeQuiz = proc ref -> do quiz <- basil find -< ref addQuiz :: Web () () case quiz of instance Formlet Email where formlet x = Email <$> formlet addQuiz = proc () -> do Just quiz -> do (unEmail <$> x) q <- input -< Just qsR <- basil (findRels DL ixQuestions) -< ref data Quiz = Quiz { subject :: String, () qs <- basil (mapM find) -< description :: String} ref <- (basil (x -> new ixQuiz x PNil)) -< S.toList qsR data Question = Question { title :: String, choiceA, q () <- display ghtml -< quiz choiceB, choiceC :: String} _ <- addQuestions -< response <- form'' responseForm -< () data Response = Response { name :: String ref as <- many getAnswer -< , email :: Email display (const $ X.toHtml "added quiz with questions.") -< (catMaybes qs) , date :: Date () display ghtml -< , answers :: [Answer] addQuestions :: Web (Ref QuizModel Quiz) ([Ref QuizModel response {answers = as} } Question]) Nothing -> display (const "Not Found") -< () data Answer = QA | QB | QC deriving (Show, Eq, Enum) addQuestions = proc q -> do data ResponseView = ResponseView { _name :: String , $(mkTList "QuizModel" [''Quiz, ''Question, ''Response]) qs <- inputMany -< () _email :: Email } type Questions = Rel QuizModel One Quiz Many Question basil ((qs,qz) -> mapM (newQuestion qz) qs) -< (qs, q) responseProj :: Response :-> ResponseView type Responses = Rel QuizModel One Quiz Many Response newQuestion :: Ref QuizModel Quiz -> Question -> M (Ref responseProj = Lens $ ResponseView <$> _name `for` lName <*> questions :: Questions Model code QuizModel Question) _email `for` lEmail Controller + View questions = Rel One ixQuiz "quiz" Many ixQuestion newQuestion refQuiz question = new ixQuestion responseForm :: Form Response "questions" question responseForm = projectedForm responseProj emptyResponse responses :: Responses (PCons (refQuiz, DR, where emptyResponse :: Response responses = Rel One ixQuiz "quiz" Many ixResponse ixQuestions) PNil) emptyResponse = Response "" (Email "") (Date "now") "responses" listQuizzes :: Web () () [] $(mkTlist "QuizRelations" [''Questions, ''Responses]) listQuizzes = proc () -> do getAnswer :: Web Question Answer instance ERModel QuizModel QuizRelations where qs <- basil' (findAll ixQuiz) -< () getAnswer = form''' answerForm relations = TCons4 questions $ TCons4 responses $ TNil4 case qs of answerForm :: Question -> Form Answer witnesses = WCons ixQuiz $ WCons ixQuestion $ WCons [] -> display X.toHtml -< "No answerForm q = F.plug ((title q +++ X.br) +++) ixResponse $ WNil $(deriveAll ''Quiz "PFQuiz") $(deriveAll ''Question "PFQuestion") _ Controller + View quizzes yet." -> display (X.concatHtml . map quizWithLink) -< qs quizWithLink :: (Ref QuizModel Quiz, Quiz) -> X.Html $ F.enumRadio [(QA, choiceA q),(QB, choiceB q),(QC, choiceC q)] Nothing $(deriveAll ''Response "PFResponse") quizWithLink (Ref _ i, q) = X.concatHtml homepage = X.toHtml "Welcome to the quiz system." type instance PF Quiz = PFQuiz [ ghtml q, X.br, static (View i) "view" data QuizForm = QuizForm {_subject :: String, _description :: type instance PF Question = PFQuestion , X.br, static (Take i) "take quiz" ] TextArea} type instance PF Response = PFResponse viewQuiz :: Web (Ref QuizModel Quiz) () quizProj :: Quiz :-> QuizForm $(mkLabels [''Quiz, ''Question, ''Response]) viewQuiz = proc ref -> do quizProj = Lens $ QuizForm <$> _subject `for` lSubject $(mkEqualities [''Quiz, ''Question, ''Response]) quiz <- basil find -< ref <*> _description `for` data QuizRoute = List | Add | View Int | Take Int case quiz of (textAreaToString % lDescription) deriving Show Just quiz -> do instance DefaultForm Quiz where form = projectedForm instance ToURL QuizRoute where Just qsR <- basil (findRels DL ixQuestions) -< ref quizProj (Quiz "" "") toURL = gtoURL . from qs <- basil (mapM find) -< instance DefaultForm Question where form = gform Nothing fromURL = fmap to . gfromURL S.toList qsR type M a = Basil QuizModel QuizRelations a $(deriveAll ''QuizRoute "PFQuizRoute") display quizWithQuestions -< (ref, type St = BasilState QuizModel QuizRelations type instance PF QuizRoute = PFQuizRoute quiz, catMaybes qs) type Web i o = WebT (MVar St) IO i o static :: QuizRoute -> String -> X.Html Nothing -> display (const "Not Found") -< () template x = X.thehtml ( (X.header $ linkStyle "/public/ static u s = X.anchor X.! [X.href $ "/" ++ renderURL (toURL URL handling quizWithQuestions :: (Ref QuizModel Quiz, Quiz, [Question]) - style.css") u)] X.<< X.toHtml s > X.Html +++ (X.body $ templateHeader +++ x)) handle :: QuizRoute -> Continuation (MVar St) IO () quizWithQuestions (Ref _ i, q, qs) = ghtml q Miscellaneous templateHeader = (X.h1 X.! [X.theclass "page"]) (X.toHtml handle Add = Cont () addQuiz +++ X.br "Quiz system") +++ menu handle List = Cont () listQuizzes +++ (X.concatHtml $ intersperse menu = X.unordList X.! [X.theclass "menu"] $ [static Add "add handle (View i) = Cont (Ref ixQuiz i) viewQuiz X.br $ (map ghtml) qs) quiz", static List "list quizzes"] handle (Take i) = Cont (Ref ixQuiz i) takeQuiz +++ static (Take i) "take quiz" linkStyle name = (X.thelink X.! [X.rel "stylesheet", X.href name]) X.noHtml $(deriveAll ''QuizForm "PFQuizForm") type instance PF QuizForm = PFQuizForm $(deriveAll ''ResponseView "PFResponseView")
  • 11.
    Adding a Quiz addQuiz:: Web () () addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
  • 12.
    Adding a Quiz Input type addQuiz :: Web () () addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
  • 13.
    Adding a Quiz Input type Output type addQuiz :: Web () () addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
  • 14.
    Adding a Quiz Input type Output type Show a form addQuiz :: Web () () addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
  • 15.
    Adding a Quiz Input type Output type Show a form addQuiz :: Web () () Store in the database addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () 1
  • 16.
    Adding a Quiz Input type Output type Show a form addQuiz :: Web () () Store in the database addQuiz = proc () → do q ← input () ref ← (basil (λx → new ixQuiz x PNil)) q ← addQuestions ref display (const $ X.toHtml "added quiz with questions.") () Arrow inputs 1
  • 17.
  • 18.
    Web interactions • Problem:HTTP is stateless • Solution: use continuations to model state
  • 19.
    The Arc Challenge 1.Ask for a user’s name 2. Show a link “click here” 3. Display their name again
  • 20.
    Solution arc :: Web() () arc = input &&& link "Click Here" >> display (λx → X.toHtml $ "Hello, " + fst x) > + 4
  • 21.
    Solution (improved) arc =proc () → do name ← input () link "Click here" () display (λn → X.toHtml $ "Hello, " + n) + name 5
  • 22.
    Web Interactions • Functionalway to describe interactions • Type-safe way of combining them • Related: • Monadic interface
  • 23.
    Library 2: Views Usinggeneric programming to reduce boilerplate code
  • 24.
    Generating HTML ghtml ::(Regular a, GHtml (PF a)) ⇒ a → X.Html data Quiz = Quiz{subject :: String , description :: String } Quiz system add quiz list quizzes Quiz Subject: What programming language are you? Description: This quiz is about what kind of programming language you are. view take quiz 6
  • 25.
    Generating HTML ghtml ::(Regular a, GHtml (PF a)) ⇒ a → X.Html data Quiz = Quiz{subject :: String , description :: String } Quiz system add quiz list quizzes Quiz Subject: What programming language are you? Description: This quiz is about what kind of programming language you are. view take quiz 6
  • 26.
    Generating HTML Sometimes thegenerated HTML needs to be changed
  • 27.
    Generating HTML Sometimes the generated HTML needs to be changed Quiz system add quiz list quizzes data User = User{name :: String User , email :: String Name: chris , password :: String Email: chris@eidhof.nl } Password: haskell98 Continue
  • 28.
    Solution: custom HTML •Error-prone • What if the input changes? • What if the HTML library changes?
  • 29.
    Solution: change datatype data User = User{name :: String , email :: String , password :: NoHtml String } • Confuses view and model code • What if there are multiple views?
  • 30.
    Solution: change datatype data User = User{name :: String , email :: String , password :: NoHtml String } • Confuses view and model code • What if there are multiple views?
  • 31.
    Non Solution: changedatatype data User = User{name :: String , email :: String , password :: NoHtml String } • Confuses view and model code • What if there are multiple views?
  • 32.
    Solution: view datatypes userToUserView:: User → UserView userToUserView u = UserView (name u) (email u) data UserView = UserView{name :: String , email :: String } 10
  • 33.
    Solution: view datatypes •We can keep using generic programming • Offer a lot of flexibility for removing, reordering and displaying of fields • We still allow manual HTML
  • 34.
    Generating forms Sometimes thegenerated forms need to be changed
  • 35.
    Generating forms Sometimes the generated forms need to be changed Quiz system add quiz list quizzes Name: Email: Date: Submit
  • 36.
    Generating forms Sometimes the generated forms need to be changed Quiz system add quiz list quizzes Name: Email: Date: Submit Quiz system add quiz list quizzes subject: description: Larger! Submit
  • 37.
    Generating forms Sometimes the generated forms need to be changed Quiz system Quiz system add quiz add quiz list quizzes list quizzes Name: name: Email: email: Date: Submit Submit Quiz system add quiz list quizzes subject: description: Larger! Submit
  • 38.
    Generating forms Sometimes the generated forms need to be changed Quiz system Quiz system add quiz add quiz list quizzes list quizzes Name: name: Quiz system Email: email: add quiz list quizzes Date: Submit subject: Submit Quiz system description: add quiz list quizzes subject: description: Larger! Submit Submit
  • 39.
    Generic Forms gform ::(Regular a, GFormlet (PF a)) ⇒ Maybe a → Form a 11
  • 40.
    Generic Forms gform ::(Regular a, GFormlet (PF a)) ⇒ Maybe a → Form a userForm :: Maybe User → Form User userForm = gform 12
  • 41.
    User Forms gform ::(Regular a, GFormlet (PF a)) ⇒ Maybe a → Form a userForm :: Maybe User → Form UserView userForm = gform ◦ fmap userToUserView 13
  • 42.
    User Forms gform ::(Regular a, GFormlet (PF a)) ⇒ Maybe a → Form a userForm :: Maybe User → Form UserView userForm = gform ◦ fmap userToUserView How to convert to a User? 13
  • 43.
    Solution: lenses convertUser ::User → UserView convertUser = Lens (UserView < > name ‘for‘ lName $ email ‘for‘ lEmail ) get convertUser :: (User → UserView) set convertUser :: (UserView → User → User) 13
  • 44.
    Solution: lenses convertUser ::User → UserView convertUser = Lens (UserView < > name ‘for‘ lName $ email ‘for‘ lEmail ) Construct a view get convertUser :: (User → UserView) set convertUser :: (UserView → User → User) 13
  • 45.
    Solution: lenses convertUser ::User → UserView convertUser = Lens (UserView < > name ‘for‘ lName $ email ‘for‘ lEmail ) Construct a view get convertUser :: (User → UserView) set convertUser :: (UserView → User → User) Update original with values from view 13
  • 46.
    Solution: lenses projectedForm ::(a → b) → a → Form a userForm :: User → Form User userForm = projectedForm convertUser 14
  • 47.
    Library 2: Summary •Using generic programming and view datatypes • Consistent UI • More applications: • API generation • API documentation
  • 48.
  • 49.
    Current approaches • HaskellDB •Happstack’s data layer • HDBC • Sirenial • ...
  • 50.
    First approach data Quiz = Quiz {subject :: String , description :: String , questions :: [Question] , responses :: [Response] } data Question = Question{title :: String , choiceA, choiceB, choiceC :: String , quiz :: Quiz } data Response = Response{name :: String , email :: Email , date :: Date , answers :: [Answer] , quiz :: Quiz } 15
  • 51.
    First approach data Quiz = Quiz {subject :: String , description :: String , questions :: [Question] , responses :: [Response] } data Question = Question{title :: String , choiceA, choiceB, choiceC :: String , quiz :: Quiz } data Response = Response{name :: String , email :: Email , date :: Date , answers :: [Answer] , quiz :: Quiz } 15
  • 52.
    First approach: problems • How to keep relationships in sync? • How to serialize?
  • 53.
    Solution: entity relationship models Subject Name Description * 1 Date Response responses Quiz 1 Email questions Answers * ChoiceA Question ChoiceB ChoiceC Title
  • 54.
    Solution: entity relationship models Attribute Subject Name Description * 1 Date Response responses Quiz 1 Email questions Answers * ChoiceA Question ChoiceB ChoiceC Title
  • 55.
    Solution: entity relationship models Attribute Subject Name Description Entity * 1 Date Response responses Quiz 1 Email questions Answers * ChoiceA Question ChoiceB ChoiceC Title
  • 56.
    Solution: entity relationship models Attribute Subject Name Description Entity * 1 Date Response responses Quiz 1 Email questions Answers Relationship * ChoiceA Question ChoiceB ChoiceC Title
  • 57.
    ER models • Conceptualmodel • Compile to logical models: • In-memory database • Relational database • Diagrams • ...
  • 58.
    ER models: constraints 1.Entities should have all the attributes 2. Cardinality is one-to-one, one-to-many, many-to-one, many-to-many 3. Relationships are only between entities in the same ER model 4. Relationships should be initialized when creating a new entity
  • 59.
    Encoding entities data Quiz= Quiz{subject :: String , description :: String } Subject Description Quiz
  • 60.
    Encoding entities data Quiz= Quiz{subject :: String , description :: String } Subject Description Quiz 1. Entities should have all the attributes
  • 61.
    Encoding entities type QuizModel= Quiz :∗: Question :∗: Response :∗: Nil ixQuiz :: Ix QuizModel Quiz ixQuestion :: Ix QuizModel Question ixResponse :: Ix QuizModel Response 17
  • 62.
    Encoding entities Type-level list type QuizModel = Quiz :∗: Question :∗: Response :∗: Nil ixQuiz :: Ix QuizModel Quiz ixQuestion :: Ix QuizModel Question ixResponse :: Ix QuizModel Response 17
  • 63.
    Encoding entities Type-level list type QuizModel = Quiz :∗: Question :∗: Response :∗: Nil ixQuiz :: Ix QuizModel Quiz ixQuestion :: Ix QuizModel Question ixResponse :: Ix QuizModel Response Typed indexes 17
  • 64.
    Encoding relationships 2. Cardinalityis one-to-one, one-to-many, many-to-one, many-to-many 3. Relationships are only between entities in the same ER model
  • 65.
    A first step Quiz data Rel cardL entityL cardR entityR where Rel :: Rel cardL entitityL cardR entityR 1 questions :: Rel QuizModel One Quiz Many Question questions questions = Rel * Question 18
  • 66.
    A first step Cardinality Quiz data Rel cardL entityL cardR entityR where Rel :: Rel cardL entitityL cardR entityR 1 questions :: Rel QuizModel One Quiz Many Question questions questions = Rel * Question 18
  • 67.
    Constraining cardinality data One dataMany data Cardinality a where One :: Cardinality One Many :: Cardinality Many data Rel cardL entityL cardR entityR where Rel :: Cardinality cardinalityL → Cardinality cardinalityR → Rel cardinalityL l cardinalityR r 19
  • 68.
    Constraining cardinality Type-level data One data Many data Cardinality a where One :: Cardinality One Many :: Cardinality Many data Rel cardL entityL cardR entityR where Rel :: Cardinality cardinalityL → Cardinality cardinalityR → Rel cardinalityL l cardinalityR r 19
  • 69.
    Constraining cardinality Type-level data One data Many data Cardinality a where Value-level One :: Cardinality One Many :: Cardinality Many data Rel cardL entityL cardR entityR where Rel :: Cardinality cardinalityL → Cardinality cardinalityR → Rel cardinalityL l cardinalityR r 19
  • 70.
    Constraining cardinality Type-level data One data Many data Cardinality a where Value-level One :: Cardinality One Many :: Cardinality Many data Rel cardL entityL cardR entityR where Rel :: Cardinality cardinalityL → Cardinality cardinalityR → Rel cardinalityL l cardinalityR r 2. Cardinality is one-to-one, one-to-many, many-to-one, many-to-many 19
  • 71.
    Constraining entities Quiz data Rel entities cardinalityL l cardinalityR r where Rel :: Cardinality cardinalityL → Ix entities l 1 → Cardinality cardinalityR → Ix entities r → Rel entities cardinalityL l cardinalityR r questions questions :: Rel QuizModel One Quiz Many Question * questions = Rel One ixQuiz Many ixQuestion Question 20
  • 72.
    Constraining entities List of all entities (type-level) Quiz data Rel entities cardinalityL l cardinalityR r where Rel :: Cardinality cardinalityL → Ix entities l 1 → Cardinality cardinalityR → Ix entities r → Rel entities cardinalityL l cardinalityR r questions questions :: Rel QuizModel One Quiz Many Question * questions = Rel One ixQuiz Many ixQuestion Question 20
  • 73.
    Constraining entities List of all entities (type-level) Quiz data Rel entities cardinalityL l cardinalityR r where Rel :: Cardinality cardinalityL → Ix entities l Indexes into list 1 → Cardinality cardinalityR → Ix entities r → Rel entities cardinalityL l cardinalityR r questions questions :: Rel QuizModel One Quiz Many Question * questions = Rel One ixQuiz Many ixQuestion Question 20
  • 74.
    Constraining entities List of all entities (type-level) Quiz data Rel entities cardinalityL l cardinalityR r where Rel :: Cardinality cardinalityL → Ix entities l Indexes into list 1 → Cardinality cardinalityR → Ix entities r → Rel entities cardinalityL l cardinalityR r questions questions :: Rel QuizModel One Quiz Many Question * questions = Rel One ixQuiz Many ixQuestion Question 3. Relationships are only between entities in the same ER model 20
  • 75.
    What have wedone? • Described entities • Described relationships • Guaranteed 3 out of 4 constraints
  • 76.
    Encoding relationships 4. Relationshipsshould be initialized when creating a new entity
  • 77.
    Adding a Question Quiz new :: Ix entities entity → entity → PList entities entity (InitialValues entities entity rels rels) rels ? 1 → Basil entities rels (Ref entities entity) questions * Question 22
  • 78.
    Adding a Question Quiz new :: Ix entities entity → entity → PList entities entity (InitialValues entities entity rels rels) rels 1 → Basil entities rels (Ref entities entity) questions * Question 22
  • 79.
    Adding a Question Quiz new :: Ix entities entity → entity → PList entities entity (InitialValues entities entity rels rels) rels 1 → Basil entities rels (Ref entities entity) questions All to-one relationships involving * this entity Question 22
  • 80.
    InitialValues function type familyInitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
  • 81.
    InitialValues function List ofall entities (type-level) type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
  • 82.
    InitialValues function List ofall entities (type-level) Current entity type type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
  • 83.
    InitialValues function List ofall entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
  • 84.
    InitialValues function List ofall entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
  • 85.
    InitialValues function List ofall entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
  • 86.
    InitialValues function List ofall entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 23
  • 87.
    InitialValues function List ofall entities (type-level) Current entity type List of relationships type family InitialValues entities r rels originalRels :: ∗ type instance InitialValues entities r Nil o = Nil type instance InitialValues entities r (Rel entities c1 from Many to :∗: xs) o = InitialValues entities r (Rel entities c1 from Many to :∗: xs) o type instance InitialValues entities r (Rel entities c1 from One to :∗: xs) o = AppendIfTrue (TypeEq r from) (InitialValue entities r L (Rel entities c1 from One to) o) (InitialValues entities r (Rel entities c1 from One to :∗: xs) o) 4. Relationships should be initialized when creating a new entity 23
  • 88.
    ER model: encoding entities data Quiz = Quiz {subject :: String, description :: String} data Question = Question{title :: String, choiceA, choiceB, choiceC :: String} data Response = Response{name :: String , email :: Email , date :: Date , answers :: [Answer] } data Answer = QA | QB | QC type QuizModel = Quiz :∗: Question :∗: Response :∗: Nil 28
  • 89.
    ER model: encoding relationships type Questions = Rel QuizModel One Quiz Many Question type Responses = Rel QuizModel One Quiz Many Response questions :: Questions questions = Rel One ixQuiz "quiz" Many ixQuestion "questions" responses :: Responses responses = Rel One ixQuiz "quiz" Many ixResponse "responses" type QuizRelations = Questions :∗: Responses :∗: Nil 29
  • 90.
    ER model: wrapup • Enforcing constraints • In-memory backend • Relational backend • Query language
  • 91.
    ER model: wrapup • Enforcing constraints • In-memory backend Same interface! • Relational backend • Query language
  • 92.
    Conclusion • Three libraries:model, view, controller • A new start for Haskell web development • Notably missing: AJAX
  • 93.
    Query language data Person= Person{name :: String, age :: Int} chris = Person "chris" 25 belowDrinkingAge :: Expr Person Bool belowDrinkingAge = age . < . Constant 18 isChris :: Expr Person Bool isChris = Not (belowDrinkingAge) .∧. name . ≡ . Constant "chris" In-memory database eval :: Expr entity a → (entity → a) toSql :: Expr entity a → String Relational database 25
  • 94.
    In-memory database newtype TypeCachea = TypeCache{ cached :: M.Map Int a} deriving Show type Cache entities = HList (TMap TypeCache entities) type family RelationStorage rel :: ∗ type instance RelationStorage (Rel entities One r1 One r2) = M.Map (Ref entities r1) (Ref entities r2) type instance RelationStorage (Rel entities One r1 Many r2) = M.Map (Ref entities r2) (Ref entities r1) type instance RelationStorage (Rel entities Many r1 One r2) = M.Map (Ref entities r1) (Ref entities r2) type instance RelationStorage (Rel entities Many r1 Many r2) = (M.Map (Ref entities r1) (S.Set (Ref entities r2)) , M.Map (Ref entities r2) (S.Set (Ref entities r1))) 26
  • 95.
    Relational Database type Tabletables atts = HList2 (Attr tables) atts data TableT a = ∀env schema.TableT {unTableT :: Table env schema , trans :: a ⇔ HList schema } table :: (Regular a, GName (PF a), GSchema (PF a) schema) ⇒ a → TableT a class AddRelationship rels tables newTables | rels tables → newTables where addRelationships :: TList4 Rel rels → HList2 TableT tables → HList2 TableT newTables liftOperations :: TList4 Rel rels → Operation tables r → Operation newTables r 27

Editor's Notes

  • #3 Ordina uses Haskell to generate PHP + MySQL!
  • #11 Continuations, views, database
  • #12 Continuations, views, database
  • #13 Continuations, views, database
  • #14 Continuations, views, database
  • #15 Continuations, views, database
  • #18 What&amp;#x2019;s the catch: you cannot store the name in the URL
  • #45 Go through visual syntax: entities, relationships, cardinality
  • #46 Go through visual syntax: entities, relationships, cardinality
  • #47 Go through visual syntax: entities, relationships, cardinality