Rewrite everything with Spock

src/Application.hs

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

src/Main.hs

@@ -1,14 +1,23 @@
-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
 
 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 = do
-  ServerSettings {..} <- newServerSettings
+  AppSettings { bindUrl
+              , bindPort
+              , urlTable } <- settings
+  table                    <- load urlTable
+
   putStrLn ("Serving on " ++ bindUrl)
-  app (runSettings warpSettings . logStdout)
+  runBreve bindPort (app bindUrl table)
+