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 Web.Frank
-import Web.Simple
-import Web.Simple.Static       (serveStatic)
-import Web.Simple.Templates    (render)
+import Views
 
 import Control.Monad.IO.Class  (liftIO)
 import Text.Printf             (printf)
 import Data.Aeson
-import qualified Data.ByteString.Lazy.Char8 as BL
-import qualified Data.ByteString.Char8      as BS
+import Data.Monoid
+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
 
-app :: (Application -> IO ()) -> IO ()
-app runner = do
-  settings            <- newAppSettings
-  ServerSettings {..} <- newServerSettings
-  table               <- load urlTable
 
-  static <- getDataFileName "static/"
-  index  <- getDataFileName "views/index.html"
-  done   <- getDataFileName "views/done.html"
+serveStatic :: FilePath -> SpockT IO ()
+serveStatic = middleware . staticPolicy . addBase
 
-  runner $ controllerApp settings $ do
-    get "/" (render index ())
 
-    get "/:file" $ do
-      file <- queryParam' "file"
-      serveStatic (static ++ file)
+app :: Url -> UrlTable -> SpockT IO ()
+app url' table = do
+  liftIO (getDataFileName "static/") >>= serveStatic
 
-    get "/:name" $ do
-      name <- queryParam' "name"
+  get "/" $ html (render index)
+
+  get var $ \name -> do
     url <- liftIO (extract table name)
     case url of
+      Nothing  -> html (render $ message "404: this one does not exist")
       Just url -> do
         logStr (printf "Resolved %s -> %s" name url)
-          respond $ redirectTo (BS.pack url)
-        Nothing  -> respond notFound
+        redirect (pack url)
 
-    post "/" $ do
-      form <- fst <$> parseForm
-      case lookup "url" form of
-        Nothing   -> respond badRequest
-        Just url' -> do
-          let url = BS.unpack url'
+  post root $ do
+    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)
-          render done $ object ["link" .= (bindUrl ++ name)]
+        let link = url' <> name
+        html (render $ done link)
 
-    post "/api" $ do
-      form <- fst <$> parseForm
-      case lookup "url" form of
-        Nothing   -> respond badRequest
-        Just url' -> do
-          let url = BS.unpack url'
+  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"     .= (bindUrl ++ name)
+        let json = object [ "link"     .= pack (url' <> name)
                           , "name"     .= name
                           , "original" .= url ]
-          respond $ okHtml (encode json)    
+        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)
+