module Web.Spock.Core
( SpockT, ActionT, spockT
, middleware, UploadedFile (..)
, defRoute, get, post, head, put, delete, patch
, request, header, cookie, body, jsonBody, jsonBody'
, files, params, param, param', setStatus, setHeader, redirect
, jumpNext
, setCookie, setCookie'
, bytes, lazyBytes, text, html, file, json, blaze
, combineRoute, subcomponent
)
where
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State hiding (get, put)
import Data.Time
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
import Prelude hiding (head)
import System.Locale
import Text.Blaze.Html (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Web.PathPieces
import Web.Spock.Routing
import Web.Spock.Wire
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
spockT :: MonadIO m
=> Warp.Port
-> (forall a. m a -> IO a)
-> SpockT m ()
-> IO ()
spockT port liftSpock routeDefs =
do spockApp <- buildApp liftSpock routeDefs
putStrLn $ "Spock is up and running on port " ++ show port
Warp.run port spockApp
get :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
get = defRoute GET
post :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
post = defRoute POST
head :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
head = defRoute HEAD
put :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
put = defRoute PUT
delete :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
delete = defRoute DELETE
patch :: MonadIO m => T.Text -> ActionT m () -> SpockT m ()
patch = defRoute PATCH
request :: MonadIO m => ActionT m Wai.Request
request = asks ri_request
header :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)
header t =
do req <- request
return $ fmap T.decodeUtf8 (lookup (CI.mk (T.encodeUtf8 t)) $ Wai.requestHeaders req)
cookie :: MonadIO m => T.Text -> ActionT m (Maybe T.Text)
cookie name =
do req <- request
return $ lookup "cookie" (Wai.requestHeaders req) >>= lookup name . parseCookies . T.decodeUtf8
where
parseCookies :: T.Text -> [(T.Text, T.Text)]
parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words
parseCookie = first T.init . T.breakOnEnd "="
body :: MonadIO m => ActionT m BS.ByteString
body =
do req <- request
let parseBody = liftIO $ Wai.requestBody req
parseAll chunks =
do bs <- parseBody
if BS.null bs
then return chunks
else parseAll (chunks `BS.append` bs)
parseAll BS.empty
jsonBody :: (MonadIO m, A.FromJSON a) => ActionT m (Maybe a)
jsonBody =
do b <- body
return $ A.decodeStrict b
jsonBody' :: (MonadIO m, A.FromJSON a) => ActionT m a
jsonBody' =
do b <- body
case A.eitherDecodeStrict' b of
Left err ->
do setStatus status500
text (T.pack $ "Failed to parse json: " ++ err)
Right val ->
return val
files :: MonadIO m => ActionT m (HM.HashMap T.Text UploadedFile)
files =
asks ri_files
params :: MonadIO m => ActionT m [(T.Text, T.Text)]
params =
do p <- asks ri_params
qp <- asks ri_queryParams
return (qp ++ (map (\(k, v) -> (unCaptureVar k, v)) $ HM.toList p))
param :: (PathPiece p, MonadIO m) => T.Text -> ActionT m (Maybe p)
param k =
do p <- asks ri_params
qp <- asks ri_queryParams
case HM.lookup (CaptureVar k) p of
Just val ->
case fromPathPiece val of
Nothing ->
do liftIO $ putStrLn ("Cannot parse " ++ show k ++ " with value " ++ show val ++ " as path piece!")
jumpNext
Just pathPieceVal ->
return $ Just pathPieceVal
Nothing ->
return $ join $ fmap fromPathPiece (lookup k qp)
param' :: (PathPiece p, MonadIO m) => T.Text -> ActionT m p
param' k =
do mParam <- param k
case mParam of
Nothing ->
do setStatus status500
text (T.concat [ "Missing parameter ", k ])
Just val ->
return val
setStatus :: MonadIO m => Status -> ActionT m ()
setStatus s =
modify $ \rs -> rs { rs_status = s }
setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
setHeader k v =
modify $ \rs -> rs { rs_responseHeaders = ((k, v) : filter ((/= k) . fst) (rs_responseHeaders rs)) }
jumpNext :: MonadIO m => ActionT m a
jumpNext = throwError ActionTryNext
redirect :: MonadIO m => T.Text -> ActionT m a
redirect = throwError . ActionRedirect
setCookie :: MonadIO m => T.Text -> T.Text -> NominalDiffTime -> ActionT m ()
setCookie name value validSeconds =
do now <- liftIO getCurrentTime
setCookie' name value (validSeconds `addUTCTime` now)
setCookie' :: MonadIO m => T.Text -> T.Text -> UTCTime -> ActionT m ()
setCookie' name value validUntil =
setHeader "Set-Cookie" rendered
where
rendered =
let formattedTime =
T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil
in T.concat [ name
, "="
, value
, "; path=/; expires="
, formattedTime
, ";"
]
bytes :: MonadIO m => BS.ByteString -> ActionT m a
bytes val =
lazyBytes $ BSL.fromStrict val
lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m a
lazyBytes val =
do modify $ \rs -> rs { rs_responseBody = ResponseLBS val }
throwError ActionDone
text :: MonadIO m => T.Text -> ActionT m a
text val =
do setHeader "Content-Type" "text/plain"
bytes $ T.encodeUtf8 val
html :: MonadIO m => T.Text -> ActionT m a
html val =
do setHeader "Content-Type" "text/html"
bytes $ T.encodeUtf8 val
file :: MonadIO m => T.Text -> FilePath -> ActionT m a
file contentType filePath =
do setHeader "Content-Type" contentType
modify $ \rs -> rs { rs_responseBody = ResponseFile filePath }
throwError ActionDone
json :: (A.ToJSON a, MonadIO m) => a -> ActionT m b
json val =
do setHeader "Content-Type" "application/json"
lazyBytes $ A.encode val
blaze :: MonadIO m => Html -> ActionT m a
blaze val =
do setHeader "Content-Type" "text/html"
lazyBytes $ renderHtml val