109 lines
3.0 KiB
Haskell
109 lines
3.0 KiB
Haskell
{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-}
|
|
import Yesod
|
|
import Yesod.Helpers.Auth
|
|
import Yesod.Helpers.Crud
|
|
import Database.Persist.Sqlite
|
|
import Data.Time (Day)
|
|
|
|
share2 mkPersist mkIsForm [$persist|
|
|
Entry
|
|
title String "label=Entry title" "tooltip=Make it something cool"
|
|
posted JqueryDay Desc
|
|
content NicHtml
|
|
deriving
|
|
|]
|
|
instance Item Entry where
|
|
itemTitle = entryTitle
|
|
|
|
getAuth = const $ Auth
|
|
{ authIsOpenIdEnabled = False
|
|
, authRpxnowApiKey = Nothing
|
|
, authEmailSettings = Nothing
|
|
-- | client id, secret and requested permissions
|
|
, authFacebook = Just (clientId, secret, ["email"])
|
|
}
|
|
where
|
|
clientId = "134280699924829"
|
|
secret = "a7685e10c8977f5435e599aaf1d232eb"
|
|
|
|
data Blog = Blog Connection
|
|
type EntryCrud = Crud Blog Entry
|
|
mkYesod "Blog" [$parseRoutes|
|
|
/ RootR GET
|
|
/entry/#EntryId EntryR GET
|
|
/admin AdminR EntryCrud defaultCrud
|
|
/auth AuthR Auth getAuth
|
|
|]
|
|
instance Yesod Blog where
|
|
approot _ = "http://localhost:3000"
|
|
defaultLayout p = do
|
|
mcreds <- maybeCreds
|
|
admin <- maybeAuthorized $ AdminR CrudListR
|
|
hamletToContent [$hamlet|
|
|
!!!
|
|
%html
|
|
%head
|
|
%title $pageTitle.p$
|
|
^pageHead.p^
|
|
%style textarea.html{width:500px;height:200px}div.tooltip{font-size:80%;font-style:italic;color:#666}
|
|
%body
|
|
%p
|
|
%a!href=@RootR@ Homepage
|
|
$maybe admin a
|
|
\ | $
|
|
%a!href=@a@ Admin
|
|
\ | $
|
|
$maybe mcreds c
|
|
Welcome $
|
|
$maybe credsDisplayName.c dn
|
|
$dn$
|
|
$nothing
|
|
$credsIdent.c$
|
|
\ $
|
|
%a!href=@AuthR.Logout@ Logout
|
|
$nothing
|
|
%a!href=@AuthR.StartFacebookR@ Facebook Connect
|
|
^pageBody.p^
|
|
%p
|
|
Powered by Yesod Web Framework
|
|
|]
|
|
isAuthorized AdminR{} = do
|
|
mc <- maybeCreds
|
|
let x = (mc >>= credsEmail) == Just "michael@snoyman.com"
|
|
return $ if x then Nothing else Just "Permission denied"
|
|
isAuthorized _ = return Nothing
|
|
instance YesodAuth Blog where
|
|
defaultDest _ = RootR
|
|
defaultLoginRoute _ = RootR
|
|
instance YesodPersist Blog where
|
|
type YesodDB Blog = SqliteReader
|
|
runDB db = do
|
|
Blog conn <- getYesod
|
|
runSqlite db conn
|
|
|
|
getRootR = do
|
|
entries <- runDB $ select [] [EntryPostedDesc]
|
|
applyLayoutW $ do
|
|
setTitle $ string "Blog tutorial homepage"
|
|
addBody [$hamlet|
|
|
%h1 All Entries
|
|
%ul
|
|
$forall entries entry
|
|
%li
|
|
%a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$
|
|
|]
|
|
|
|
getEntryR :: EntryId -> Handler Blog RepHtml
|
|
getEntryR eid = do
|
|
entry <- runDB (get eid) >>= maybe notFound return
|
|
applyLayoutW $ do
|
|
setTitle $ string $ entryTitle entry
|
|
addBody [$hamlet|
|
|
%h1 $entryTitle.entry$
|
|
%h2 $show.unJqueryDay.entryPosted.entry$
|
|
#content $unNicHtml.entryContent.entry$
|
|
|]
|
|
main = withSqlite "blog.db3" $ \conn -> do
|
|
flip runSqlite conn $ initialize (undefined :: Entry)
|
|
toWaiApp (Blog conn) >>= basicHandler 3000
|