packages feed

informative-0.1.0.4: informative-test.hs

{-# 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 = SqlPersistT
  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
         <html>
           <head>
             <title>#{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