module Snap.App.Controller
(runHandler
,output
,outputText
,goHome
,justOrGoHome
,getInteger
,getString
,getStringMaybe
,getPagination
,getMyURI)
where
import Snap.Core
import Snap.App.Model (Pool,withPoolConnection)
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.String
import Data.Pagination
import Network.URI
import Data.Text.Lazy (Text,toStrict)
import Database.PostgreSQL.Simple
import Safe (readMay)
import Text.Blaze (Html)
import Text.Blaze.Renderer.Text (renderHtml)
import Text.Blaze.Pagination (PN(..))
runHandler :: s -> c -> Pool -> Controller c s () -> Snap ()
runHandler st conf pool ctrl = do
withPoolConnection pool $ \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 => String -> Controller c s PN
getPagination name = do
p <- getInteger (fromString (name ++ "_page")) 1
limit <- getInteger (fromString (name ++ "_per_page")) 35
uri <- getMyURI
let pag = Pagination { pnCurrentPage = max 1 p
, pnPerPage = max 1 (min 100 limit)
, pnTotal = 0
, pnName = "events"
, pnShowDesc = True
}
return (PN uri pag Nothing)
getMyURI :: AppConfig c => Controller c s URI
getMyURI = do
domain <- env (getConfigDomain . controllerStateConfig)
result <- fmap (parseURI . (("http://" ++ domain) ++) . toString . rqURI)
getRequest
case result of
Nothing -> case parseURI ("http://" ++ domain) of
Nothing -> error $ "Unable to parse my own domain! It's this: " ++ domain
Just d -> return d
Just d -> return d