Last active
November 12, 2021 12:06
-
-
Save yuanotes/6985578 to your computer and use it in GitHub Desktop.
simple blog by haskell and yesod
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes, | |
| TemplateHaskell, GADTs, FlexibleContexts, | |
| MultiParamTypeClasses, DeriveDataTypeable #-} | |
| import Yesod | |
| import Yesod.Auth | |
| import Yesod.Form.Nic (YesodNic, nicHtmlField) | |
| import Yesod.Auth.BrowserId (authBrowserId) | |
| import Data.Text (Text) | |
| import Network.HTTP.Conduit (Manager, newManager, def) | |
| import Database.Persist.Sqlite | |
| ( ConnectionPool, SqlPersistT, runSqlPool, runMigration | |
| , createSqlitePool, runSqlPersistMPool | |
| ) | |
| import Data.Time (UTCTime, getCurrentTime) | |
| import Control.Applicative ((<$>), (<*>), pure) | |
| import Data.Typeable (Typeable) | |
| share [mkPersist sqlOnlySettings, mkMigrate "migrateAll"] [persistLowerCase| | |
| User | |
| email Text | |
| UniqueUser email | |
| deriving Typeable | |
| Entry | |
| title Text | |
| posted UTCTime | |
| content Html | |
| Comment | |
| entry EntryId | |
| posted UTCTime | |
| user UserId | |
| name Text | |
| text Textarea | |
| |] | |
| data Blog = Blog { | |
| connPool :: ConnectionPool, | |
| httpManager :: Manager | |
| } | |
| mkMessage "Blog" "." "en" | |
| mkYesod "Blog" [parseRoutes| | |
| / HomeR GET | |
| /blog BlogR GET POST | |
| /blog/#EntryId EntryR GET POST | |
| /auth AuthR Auth getAuth | |
| |] | |
| instance Yesod Blog where | |
| approot = ApprootStatic "http://localhost:3000" | |
| isAuthorized BlogR True = do | |
| mauth <- maybeAuth | |
| case mauth of | |
| Nothing -> return AuthenticationRequired | |
| Just (Entity _ user) | |
| | isAdmin user -> return Authorized | |
| | otherwise -> unauthorizedI MsgNotAnAdmin | |
| isAuthorized (EntryR _) True = do | |
| mauth <- maybeAuth | |
| case mauth of | |
| Nothing -> return AuthenticationRequired | |
| Just _ -> return Authorized | |
| isAuthorized _ _ = return Authorized | |
| authRoute _ = Just (AuthR LoginR) | |
| defaultLayout inside = do | |
| mmsg <- getMessage | |
| pc <- widgetToPageContent $ do | |
| toWidget [lucius| | |
| body { | |
| width: 760px; | |
| margin: 1em auto; | |
| font-family: sans-serif; | |
| } | |
| textarea { | |
| width: 400px; | |
| height: 200px; | |
| } | |
| #message { | |
| color: #900; | |
| } | |
| |] | |
| inside | |
| giveUrlRenderer [hamlet| | |
| $doctype 5 | |
| <html> | |
| <head> | |
| <title>#{pageTitle pc} | |
| ^{pageHead pc} | |
| <body> | |
| $maybe msg <- mmsg | |
| <div #message>#{msg} | |
| ^{pageBody pc} | |
| |] | |
| isAdmin :: User -> Bool | |
| isAdmin user = userEmail user == "[email protected]" | |
| instance YesodPersist Blog where | |
| type YesodPersistBackend Blog = SqlPersistT | |
| runDB f = do | |
| master <- getYesod | |
| let pool = connPool master | |
| runSqlPool f pool | |
| type Form x = Html -> MForm Handler (FormResult x, Widget) | |
| instance RenderMessage Blog FormMessage where | |
| renderMessage _ _ = defaultFormMessage | |
| instance YesodNic Blog | |
| instance YesodAuth Blog where | |
| type AuthId Blog = UserId | |
| loginDest _ = HomeR | |
| logoutDest _ = HomeR | |
| authHttpManager = httpManager | |
| authPlugins _ = [authBrowserId def] | |
| getAuthId creds = do | |
| let email = credsIdent creds | |
| user = User email | |
| res <- runDB $ insertBy user | |
| return $ Just $ either entityKey id res | |
| getHomeR :: Handler Html | |
| getHomeR = defaultLayout $ do | |
| setTitleI MsgHomepageTitle | |
| [whamlet| | |
| <p>_{MsgWelcomeHomepage} | |
| <p> | |
| <a href=@{BlogR}>_{MsgSeeArchive} | |
| |] | |
| entryForm :: Form Entry | |
| entryForm = renderDivs $ Entry | |
| <$> areq textField (fieldSettingsLabel MsgNewEntryTitle) Nothing | |
| <*> lift (liftIO getCurrentTime) | |
| <*> areq nicHtmlField (fieldSettingsLabel MsgNewEntryContent) Nothing | |
| getBlogR :: Handler Html | |
| getBlogR = do | |
| muser <- maybeAuth | |
| entries <- runDB $ selectList [] [Desc EntryPosted] | |
| (entryWidget, enctype) <- generateFormPost entryForm | |
| defaultLayout $ do | |
| setTitleI MsgBlogArchiveTitle | |
| [whamlet| | |
| $if null entries | |
| <p>_{MsgNoEntries} | |
| $else | |
| <ul> | |
| $forall Entity entryId entry <- entries | |
| <li> | |
| <a href=@{EntryR entryId}>#{entryTitle entry} | |
| $maybe Entity _ user <- muser | |
| $if isAdmin user | |
| <form method=post enctype=#{enctype}> | |
| ^{entryWidget} | |
| <div> | |
| <input type=submit value=_{MsgNewEntry}> | |
| $nothing | |
| <p> | |
| <a href=@{AuthR LoginR}>_{MsgLoginToPost} | |
| |] | |
| postBlogR :: Handler Html | |
| postBlogR = do | |
| ((res, entryWidget), enctype) <- runFormPost entryForm | |
| case res of | |
| FormSuccess entry -> do | |
| entryId <- runDB $ insert entry | |
| setMessageI $ MsgEntryCreated $ entryTitle entry | |
| redirect $ EntryR entryId | |
| _ -> defaultLayout $ do | |
| setTitleI MsgPleaseCorrectEntry | |
| [whamlet| | |
| <form method=post enctype=#{enctype}> | |
| ^{entryWidget} | |
| <div> | |
| <input type=submit value=_{MsgNewEntry}> | |
| |] | |
| commentForm :: EntryId -> Form Comment | |
| commentForm entryId = renderDivs $ Comment | |
| <$> pure entryId | |
| <*> lift (liftIO getCurrentTime) | |
| <*> lift requireAuthId | |
| <*> areq textField (fieldSettingsLabel MsgCommentName) Nothing | |
| <*> areq textareaField (fieldSettingsLabel MsgCommentText) Nothing | |
| getEntryR :: EntryId -> Handler Html | |
| getEntryR entryId = do | |
| (entry, comments) <- runDB $ do | |
| entry <- get404 entryId | |
| comments <- selectList [] [Asc CommentPosted] | |
| return (entry, map entityVal comments) | |
| muser <- maybeAuth | |
| (commentWidget, enctype) <- | |
| generateFormPost (commentForm entryId) | |
| defaultLayout $ do | |
| setTitleI $ MsgEntryTitle $ entryTitle entry | |
| [whamlet| | |
| <h1>#{entryTitle entry} | |
| <article>#{entryContent entry} | |
| <section .comments> | |
| <h1>_{MsgCommentsHeading} | |
| $if null comments | |
| <p>_{MsgNoComments} | |
| $else | |
| $forall Comment _entry posted _user name text <- comments | |
| <div .comment> | |
| <span .by>#{name} | |
| <span .at>#{show posted} | |
| <div .content>#{text} | |
| <section> | |
| <h1>_{MsgAddCommentHeading} | |
| $maybe _ <- muser | |
| <form method=post enctype=#{enctype}> | |
| ^{commentWidget} | |
| <div> | |
| <input type=submit value=_{MsgAddCommentButton}> | |
| $nothing | |
| <p> | |
| <a href=@{AuthR LoginR}>_{MsgLoginToComment} | |
| |] | |
| postEntryR :: EntryId -> Handler Html | |
| postEntryR entryId = do | |
| ((res, commentWidget), enctype) <- | |
| runFormPost (commentForm entryId) | |
| case res of | |
| FormSuccess comment -> do | |
| _ <- runDB $ insert comment | |
| setMessageI MsgCommentAdded | |
| redirect $ EntryR entryId | |
| _ -> defaultLayout $ do | |
| setTitleI MsgPleaseCorrectComment | |
| [whamlet| | |
| <form method=post enctype=#{enctype}> | |
| ^{commentWidget} | |
| <div> | |
| <input type=submit value=_{MsgAddCommentButton}> | |
| |] | |
| main :: IO () | |
| main = do | |
| pool <- createSqlitePool "blog.db3" 10 -- create a new pool | |
| -- perform any necessary migration | |
| runSqlPersistMPool (runMigration migrateAll) pool | |
| manager <- newManager def -- create a new HTTP manager | |
| warp 3000 $ Blog pool manager -- start our server |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment