module Web.Spock.Core
( SpockT, ActionT, spockT
, middleware, UploadedFile (..)
, defRoute, get, post, head, put, delete, patch
, request, header, cookie, body, jsonBody
, files, params, param, setStatus, setHeader, redirect
, setCookie, setCookie'
, bytes, lazyBytes, text, html, file, json, blaze
, combineRoute, subcomponent
)
where
import Control.Arrow (first)
import Control.Monad
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
liftIO $ Wai.requestBody req
jsonBody :: (MonadIO m, A.FromJSON a) => ActionT m (Maybe a)
jsonBody =
do b <- body
return $ A.decodeStrict b
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
let findP f wrapK x = join $ fmap fromPathPiece (f (wrapK k) x)
paramVal = findP HM.lookup CaptureVar p
queryVal = findP lookup id qp
case paramVal of
Just pVal -> return (Just pVal)
Nothing -> return queryVal
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)) }
redirect :: MonadIO m => T.Text -> ActionT m ()
redirect url =
modify $ \rs -> rs { rs_responseBody = ResponseRedirect url }
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 ()
bytes val =
lazyBytes $ BSL.fromStrict val
lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m ()
lazyBytes val =
modify $ \rs -> rs { rs_responseBody = ResponseLBS val }
text :: MonadIO m => T.Text -> ActionT m ()
text val =
do setHeader "Content-Type" "text/plain"
bytes $ T.encodeUtf8 val
html :: MonadIO m => T.Text -> ActionT m ()
html val =
do setHeader "Content-Type" "text/html"
bytes $ T.encodeUtf8 val
file :: MonadIO m => T.Text -> FilePath -> ActionT m ()
file contentType filePath =
do setHeader "Content-Type" contentType
modify $ \rs -> rs { rs_responseBody = ResponseFile filePath }
json :: (A.ToJSON a, MonadIO m) => a -> ActionT m ()
json val =
do setHeader "Content-Type" "application/json"
lazyBytes $ A.encode val
blaze :: MonadIO m => Html -> ActionT m ()
blaze val =
do setHeader "Content-Type" "text/html"
lazyBytes $ renderHtml val