{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings, GADTs #-} import Control.Monad import Control.Monad.Logger (runStderrLoggingT) import Data.Text import Database.Persist.Postgresql import Network.HTTP.Conduit (Manager, conduitManagerSettings, newManager) import Web.Informative import Web.Informative.Data import Yesod import Yesod.Auth import Yesod.Auth.Dummy import Yesod.Core.Handler data Master = Master { getInformative :: Informative, getWikiPool :: ConnectionPool, httpManager :: Manager } mkYesod "Master" [parseRoutes| /wiki SubsiteR Informative getInformative /auth AuthR Auth getAuth |] instance Yesod Master where authRoute _ = Just $ AuthR LoginR isAuthorized (SubsiteR _) True = mayWrite isAuthorized (SubsiteR (EditR _)) _ = mayWrite isAuthorized _ _ = return Authorized mayWrite = do mu <- maybeAuthId return $ case mu of Nothing -> AuthenticationRequired Just "admin" -> Authorized Just _ -> Unauthorized "You must be an admin" instance RenderMessage Master FormMessage where renderMessage _ _ = defaultFormMessage instance YesodPersist Master where type YesodPersistBackend Master = SqlBackend runDB action = do pool <- liftM getWikiPool getYesod runSqlPool action pool instance YesodAuth Master where type AuthId Master = Text getAuthId = return . Just . credsIdent loginDest _ = SubsiteR $ ArticleR "main" logoutDest _ = SubsiteR $ ArticleR "main" authPlugins _ = [authDummy] authHttpManager = httpManager maybeAuthId = lookupSession "_ID" instance YesodWikiAuth Master where getAuthR = return AuthR getUserName = do muid <- maybeAuthId case muid of Nothing -> return "Anonymous" Just uid -> return uid isLoggedIn = do ma <- maybeAuthId return $ maybe False (const True) ma wikiLayout widget = do pc <- widgetToPageContent widget giveUrlRenderer [hamlet| $doctype 5 #{pageTitle pc} ^{pageHead pc} <body> ^{pageBody pc} |] main = runStderrLoggingT $ withPostgresqlPool "host=localhost port=5432 user=darkness dbname=darkness_wiki" 5 $ \pool -> do runSqlPool (runMigration migrateWiki) pool manager <- liftIO $ newManager conduitManagerSettings liftIO $ warp 3000 $ Master (Informative "test" "Test Wiki: ") pool manager