module Snap.App.Controller
(runHandler
,output
,outputText
,goHome
,justOrGoHome
,getInteger
,getString
,getStringMaybe
,getPagination
,getMyURI)
where
import Snap.Core
import Snap.App.Types
import Control.Applicative
import Control.Monad.Env
import Control.Monad.Reader (runReaderT)
import Data.ByteString (ByteString)
import Data.ByteString.UTF8 (toString)
import Data.Maybe
import Network.URI
import Data.Text.Lazy (Text,toStrict)
import Database.PostgreSQL.Base (withPoolConnection,withTransaction)
import Database.PostgreSQL.Simple (Pool)
import Safe (readMay)
import Text.Blaze (Html)
import Text.Blaze.Renderer.Text (renderHtml)
runHandler :: s -> c -> Pool -> Controller c s () -> Snap ()
runHandler st conf pool ctrl = do
withPoolConnection pool $ \conn -> do
withTransaction conn $ do
let state = ControllerState conf conn st
modifyResponse $ setContentType "text/html"
runReaderT (runController ctrl) state
output :: Html -> Controller c s ()
output html = outputText $ renderHtml $ html
outputText :: Text -> Controller c s ()
outputText text = do
let !x = toStrict $ text
writeText x
goHome :: Controller c s ()
goHome = redirect "/"
justOrGoHome :: Maybe a -> (a -> Controller c s ()) -> Controller c s ()
justOrGoHome x m = maybe goHome m x
getInteger :: ByteString -> Integer -> Controller c s Integer
getInteger name def = do
pid <- (>>= readMay . toString) <$> getParam name
maybe (return def) return pid
getString :: ByteString -> String -> Controller c s String
getString name def = do
pid <- (>>= return . toString) <$> getParam name
maybe (return def) return pid
getStringMaybe :: ByteString -> Controller c s (Maybe String)
getStringMaybe name = do
pid <- (>>= return . toString) <$> getParam name
return pid
getPagination :: AppConfig c => Controller c s Pagination
getPagination = do
p <- getInteger "page" 1
limit <- getInteger "limit" 35
uri <- getMyURI
return Pagination { pnPage = max 1 p
, pnLimit = max 1 (min 100 limit)
, pnURI = uri
, pnResults = 0
, pnTotal = 0
}
getMyURI :: AppConfig c => Controller c s URI
getMyURI = do
domain <- env (getConfigDomain . controllerStateConfig)
fmap (fromJust .
parseURI .
(("http://" ++ domain) ++) .
toString .
rqURI)
getRequest