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

Rewrite everything with Spock

Browse Source
This commit is contained in:
rnhmjoj 2015-05-09 22:24:33 +02:00
parent cd478b74fe
commit 2d6220b593
2 changed files with 63 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
src/Application.hs
View File

@ -1,68 +1,63 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards #-} {-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
module Application where module Application where
import Breve.Common import Breve.Generator
import Breve.UrlTable import Breve.UrlTable
import Paths_breve (getDataFileName) import Paths_breve (getDataFileName)
import Views
import Web.Frank
import Web.Simple
import Web.Simple.Static (serveStatic)
import Web.Simple.Templates (render)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Text.Printf (printf) import Text.Printf (printf)
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BL import Data.Monoid
import qualified Data.ByteString.Char8 as BS import Data.Text (pack, unpack)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Text.Lazy (toStrict)
import Web.Spock.Safe
import Network.Wai.Middleware.Static
logStr :: String -> ActionT IO ()
logStr = liftIO . putStrLn logStr = liftIO . putStrLn
app :: (Application -> IO ()) -> IO ()
app runner = do
settings <- newAppSettings
ServerSettings {..} <- newServerSettings
table <- load urlTable
static <- getDataFileName "static/" serveStatic :: FilePath -> SpockT IO ()
index <- getDataFileName "views/index.html" serveStatic = middleware . staticPolicy . addBase
done <- getDataFileName "views/done.html"
runner $ controllerApp settings $ do
get "/" (render index ())
get "/:file" $ do app :: Url -> UrlTable -> SpockT IO ()
file <- queryParam' "file" app url' table = do
serveStatic (static ++ file) liftIO (getDataFileName "static/") >>= serveStatic
get "/:name" $ do get "/" $ html (render index)
name <- queryParam' "name"
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")
Just url -> do Just url -> do
logStr (printf "Resolved %s -> %s" name url) logStr (printf "Resolved %s -> %s" name url)
respond $ redirectTo (BS.pack url) redirect (pack url)
Nothing -> respond notFound
post "/" $ do post root $ do
form <- fst <$> parseForm url <- fmap unpack <$> param "url"
case lookup "url" form of case url of
Nothing -> respond badRequest Nothing -> html (render $ message "bad request")
Just url' -> do Just url -> do
let url = BS.unpack url'
name <- liftIO (insert table url) name <- liftIO (insert table url)
logStr (printf "Registered %s -> %s " url name) logStr (printf "Registered %s -> %s " url name)
render done $ object ["link" .= (bindUrl ++ name)] let link = url' <> name
html (render $ done link)
post "/api" $ do post "api" $ do
form <- fst <$> parseForm url <- fmap unpack <$> param "url"
case lookup "url" form of case url of
Nothing -> respond badRequest Nothing -> text "bad request"
Just url' -> do Just url -> do
let url = BS.unpack url'
name <- liftIO (insert table url) name <- liftIO (insert table url)
logStr (printf "Registered %s -> %s " url name) logStr (printf "Registered %s -> %s " url name)
let json = object [ "link" .= (bindUrl ++ name) let json = object [ "link" .= pack (url' <> name)
, "name" .= name , "name" .= name
, "original" .= url ] , "original" .= url ]
respond $ okHtml (encode json) text (toStrict $ decodeUtf8 $ encode json)

23
src/Main.hs
View File

@ -1,14 +1,23 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards #-} {-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
import Application import Application
import Breve.Common import Breve.Settings
import Breve.UrlTable
import Web.Spock.Safe
runBreve :: Int -> SpockT IO () -> IO ()
runBreve port app = runSpock port (spockT id app)
import Control.Applicative
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger
main :: IO () main :: IO ()
main = do main = do
ServerSettings {..} <- newServerSettings AppSettings { bindUrl
, bindPort
, urlTable } <- settings
table <- load urlTable
putStrLn ("Serving on " ++ bindUrl) putStrLn ("Serving on " ++ bindUrl)
app (runSettings warpSettings . logStdout) runBreve bindPort (app bindUrl table)