rnhmjoj
/
breve
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Set status codes on error

master
rnhmjoj 2015-05-10 15:37:59 +02:00
parent 19e71ff950
commit 96b52fcdea
2 changed files with 17 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
breve.cabal
View File

@ -30,8 +30,9 @@ executable breve
Breve.Generator, Breve.UrlTable Breve.Generator, Breve.UrlTable
other-extensions: OverloadedStrings other-extensions: OverloadedStrings
build-depends: base >=4.8 && <5.0, warp, build-depends: base >=4.8 && <5.0, warp,
Spock, blaze-html, transformers, mtl, Spock, blaze-html, http-types,
wai, wai-middleware-static, wai-extra, wai, wai-middleware-static, wai-extra,
transformers, mtl,
text, aeson, bytestring, binary, text, aeson, bytestring, binary,
hashtables, cryptohash, random, hashtables, cryptohash, random,
xdg-basedir, configurator, directory xdg-basedir, configurator, directory

22
src/Application.hs
View File

@ -15,6 +15,7 @@ import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Text.Lazy (toStrict) import Data.Text.Lazy (toStrict)
import Web.Spock.Safe import Web.Spock.Safe
import Network.HTTP.Types.Status
import Network.Wai (Middleware) import Network.Wai (Middleware)
import Network.Wai.Middleware.Static import Network.Wai.Middleware.Static
import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.RequestLogger
@ -27,6 +28,10 @@ serveStatic :: FilePath -> Middleware
serveStatic = staticPolicy . addBase serveStatic = staticPolicy . addBase
reply :: Status -> String -> ActionT IO ()
reply code text = setStatus code >> render (message text)
app :: Url -> UrlTable -> SpockT IO () app :: Url -> UrlTable -> SpockT IO ()
app url' table = do app url' table = do
static <- liftIO (getDataFileName "static/") static <- liftIO (getDataFileName "static/")
@ -39,15 +44,15 @@ app url' table = do
get var $ \name -> do get var $ \name -> do
url <- liftIO (extract table name) url <- liftIO (extract table name)
case url of case url of
Nothing -> html (render $ message "404: this one does not exist") Nothing -> reply status404 "404: does not exist"
Just url -> do Just url -> do
logStr (printf "Resolved %s -> %s" name url) logStr (printf "Resolved %s -> %s" name url)
redirect (pack url) redirect (pack url)
post "/" $ do post "/" $ do
url <- fmap unpack <$> param "url" url <- param "url"
case url of case unpack <$> url of
Nothing -> html (render $ message "bad request") Nothing -> reply status400 "400: bad request"
Just url -> do Just url -> do
name <- liftIO (insert table url) name <- liftIO (insert table url)
logStr (printf "Registered %s -> %s " url name) logStr (printf "Registered %s -> %s " url name)
@ -55,9 +60,12 @@ app url' table = do
render (done link) render (done link)
post "api" $ do post "api" $ do
url <- fmap unpack <$> param "url" url <- param "url"
case url of case unpack <$> url of
Nothing -> text "bad request" Nothing -> do
setStatus status400
json $ object [ "error" .= pack "bad request"
, "msg" .= pack "missing url field" ]
Just url -> do Just url -> do
name <- liftIO (insert table url) name <- liftIO (insert table url)
logStr (printf "Registered %s -> %s " url name) logStr (printf "Registered %s -> %s " url name)