module Web.Scotty
(
scotty, scottyApp
, middleware, get, post, put, delete, addroute
, request, param
, status, header, redirect
, text, html, file, json
, raise, rescue, next
, ScottyM, ActionM, Parsable
) where
import Blaze.ByteString.Builder (fromByteString, fromLazyByteString)
import Control.Applicative
import qualified Control.Exception as E
import qualified Control.DeepSeq as DS
import Control.Monad.Error
import Control.Monad.Reader
import qualified Control.Monad.State as MS
import Control.Monad.Trans.Resource (ResourceT)
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as B
import qualified Data.CaseInsensitive as CI
import Data.Default (Default, def)
import Data.Conduit.List (consume)
import Data.Conduit (($$))
import Data.Maybe (fromMaybe)
import Data.Monoid (mconcat)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as E
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp (Port, run)
import Prelude hiding (catch)
import Web.Scotty.Util
data ScottyState = ScottyState {
middlewares :: [Middleware],
routes :: [Middleware]
}
instance Default ScottyState where
def = ScottyState [] []
newtype ScottyM a = S { runS :: MS.StateT ScottyState IO a }
deriving (Monad, MonadIO, Functor, MS.MonadState ScottyState)
scotty :: Port -> ScottyM () -> IO ()
scotty p s = putStrLn "Setting phasers to stun... (ctrl-c to quit)" >> (run p =<< scottyApp s)
scottyApp :: ScottyM () -> IO Application
scottyApp defs = do
s <- MS.execStateT (runS defs) def
return $ foldl (flip ($)) notFoundApp $ routes s ++ middlewares s
notFoundApp :: Application
notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html")]
$ fromByteString "<h1>404: File Not Found!</h1>"
middleware :: Middleware -> ScottyM ()
middleware m = MS.modify (\ (ScottyState ms rs) -> ScottyState (m:ms) rs)
type Param = (T.Text, T.Text)
data ActionError = Redirect T.Text
| ActionError T.Text
| Next
deriving (Eq,Show)
instance Error ActionError where
strMsg = ActionError . T.pack
newtype ActionM a = AM { runAM :: ErrorT ActionError (ReaderT (Request,[Param]) (MS.StateT Response IO)) a }
deriving ( Monad, MonadIO, Functor
, MonadReader (Request,[Param]), MS.MonadState Response, MonadError ActionError)
runAction :: [Param] -> ActionM () -> Request -> ResourceT IO (Maybe Response)
runAction ps action req = do
(e,r) <- lift $ flip MS.runStateT def
$ flip runReaderT (req, ps ++ queryParams req)
$ runErrorT
$ runAM
$ action `catchError` defaultHandler
return $ either (const Nothing) (const $ Just r) e
defaultHandler :: ActionError -> ActionM ()
defaultHandler (Redirect url) = do
status status302
header "Location" url
defaultHandler (ActionError msg) = do
status status500
html $ mconcat ["<h1>500 Internal Server Error</h1>", msg]
defaultHandler Next = next
raise :: T.Text -> ActionM a
raise = throwError . ActionError
next :: ActionM a
next = throwError Next
rescue :: ActionM a -> (T.Text -> ActionM a) -> ActionM a
rescue action handler = catchError action $ \e -> case e of
ActionError msg -> handler msg
other -> throwError other
redirect :: T.Text -> ActionM ()
redirect = throwError . Redirect
request :: ActionM Request
request = fst <$> ask
param :: (Parsable a) => T.Text -> ActionM a
param k = do
val <- lookup k <$> snd <$> ask
case val of
Nothing -> raise $ mconcat ["Param: ", k, " not found!"]
Just v -> maybe next return =<< liftIO (parseParam v)
class Parsable a where
parseParam :: T.Text -> IO (Maybe a)
parseParamList :: T.Text -> IO (Maybe [a])
parseParamList t = sequence <$> mapM parseParam (T.split (==',') t)
instance Parsable T.Text where parseParam = return . Just
instance Parsable B.ByteString where parseParam = return . Just . lazyTextToStrictByteString
instance Parsable Char where
parseParam t = case T.unpack t of
[c] -> return $ Just c
_ -> return Nothing
parseParamList = return . Just . T.unpack
instance Parsable () where
parseParam t = if T.null t then return (Just ()) else return Nothing
instance (Parsable a) => Parsable [a] where parseParam = parseParamList
instance Parsable Bool where parseParam = readMaybe
instance Parsable Double where parseParam = readMaybe
instance Parsable Float where parseParam = readMaybe
instance Parsable Int where parseParam = readMaybe
instance Parsable Integer where parseParam = readMaybe
readMaybe :: (Read a, DS.NFData a) => T.Text -> IO (Maybe a)
readMaybe tv = E.handleJust E.fromException
(\(_::E.ErrorCall) -> return Nothing)
$ return DS.$!! Just $ read $ T.unpack tv
get :: T.Text -> ActionM () -> ScottyM ()
get = addroute GET
post :: T.Text -> ActionM () -> ScottyM ()
post = addroute POST
put :: T.Text -> ActionM () -> ScottyM ()
put = addroute PUT
delete :: T.Text -> ActionM () -> ScottyM ()
delete = addroute DELETE
addroute :: StdMethod -> T.Text -> ActionM () -> ScottyM ()
addroute method path action = MS.modify (\ (ScottyState ms rs) -> ScottyState ms (r:rs))
where r = route method withSlash action
withSlash = case T.uncons path of
Just ('/',_) -> path
_ -> T.cons '/' path
route :: StdMethod -> T.Text -> ActionM () -> Middleware
route method path action app req =
if Right method == parseMethod (requestMethod req)
then case matchRoute path (strictByteStringToLazyText $ rawPathInfo req) of
Just captures -> do
formParams <- parseFormData method req
res <- runAction (captures ++ formParams) action req
maybe tryNext return res
Nothing -> tryNext
else tryNext
where tryNext = app req
matchRoute :: T.Text -> T.Text -> Maybe [Param]
matchRoute pat req = go (T.split (=='/') pat) (T.split (=='/') req) []
where go [] [] ps = Just ps
go [] r ps | T.null (mconcat r) = Just ps
| otherwise = Nothing
go p [] ps | T.null (mconcat p) = Just ps
| otherwise = Nothing
go (p:ps) (r:rs) prs | p == r = go ps rs prs
| T.null p = Nothing
| T.head p == ':' = go ps rs $ (T.tail p, r) : prs
| otherwise = Nothing
parseFormData :: StdMethod -> Request -> ResourceT IO [Param]
parseFormData POST req = case lookup "Content-Type" [(CI.mk k, CI.mk v) | (k,v) <- requestHeaders req] of
Just "application/x-www-form-urlencoded" -> do reqBody <- mconcat <$> (requestBody req $$ consume)
return $ parseEncodedParams reqBody
_ -> do lift $ putStrLn "Unsupported form data encoding. TODO: Fix"
return []
parseFormData _ _ = return []
queryParams :: Request -> [Param]
queryParams = parseEncodedParams . rawQueryString
parseEncodedParams :: B.ByteString -> [Param]
parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ]
status :: Status -> ActionM ()
status = MS.modify . setStatus
header :: T.Text -> T.Text -> ActionM ()
header k v = MS.modify $ setHeader (CI.mk $ lazyTextToStrictByteString k, lazyTextToStrictByteString v)
text :: T.Text -> ActionM ()
text t = do
header "Content-Type" "text/plain"
MS.modify $ setContent $ Left $ fromLazyByteString $ E.encodeUtf8 t
html :: T.Text -> ActionM ()
html t = do
header "Content-Type" "text/html"
MS.modify $ setContent $ Left $ fromLazyByteString $ E.encodeUtf8 t
file :: FilePath -> ActionM ()
file = MS.modify . setContent . Right
json :: (A.ToJSON a) => a -> ActionM ()
json v = do
header "Content-Type" "application/json"
MS.modify $ setContent $ Left $ fromLazyByteString $ A.encode v