75 lines
2.0 KiB
Haskell
75 lines
2.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Application where
|
|
|
|
import Breve.Generator
|
|
import Breve.UrlTable
|
|
import Paths_breve (getDataFileName)
|
|
import Views
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Text.Printf (printf)
|
|
import Data.Aeson hiding (json)
|
|
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.HTTP.Types.Status
|
|
import Network.Wai (Middleware)
|
|
import Network.Wai.Middleware.Static
|
|
import Network.Wai.Middleware.RequestLogger
|
|
|
|
logStr :: String -> ActionT IO ()
|
|
logStr = liftIO . putStrLn
|
|
|
|
|
|
serveStatic :: FilePath -> Middleware
|
|
serveStatic = staticPolicy . addBase
|
|
|
|
|
|
reply :: Status -> String -> ActionT IO ()
|
|
reply code text = setStatus code >> render (message text)
|
|
|
|
|
|
app :: Url -> UrlTable -> SpockT IO ()
|
|
app url' table = do
|
|
static <- liftIO (getDataFileName "static/")
|
|
|
|
middleware (serveStatic static)
|
|
middleware logStdout
|
|
|
|
get "/" $ render index
|
|
|
|
get var $ \name -> do
|
|
url <- liftIO (extract table name)
|
|
case url of
|
|
Nothing -> reply status404 "404: does not exist"
|
|
Just url -> do
|
|
logStr (printf "Resolved %s -> %s" name url)
|
|
redirect (pack url)
|
|
|
|
post "/" $ do
|
|
url <- param "url"
|
|
case unpack <$> url of
|
|
Nothing -> reply status400 "400: bad request"
|
|
Just url -> do
|
|
name <- liftIO (insert table url)
|
|
logStr (printf "Registered %s -> %s " url name)
|
|
let link = url' <> name
|
|
render (done link)
|
|
|
|
post "api" $ do
|
|
url <- param "url"
|
|
case unpack <$> url of
|
|
Nothing -> do
|
|
setStatus status400
|
|
json $ object [ "error" .= pack "bad request"
|
|
, "msg" .= pack "missing url field" ]
|
|
Just url -> do
|
|
name <- liftIO (insert table url)
|
|
logStr (printf "Registered %s -> %s " url name)
|
|
json $ object [ "link" .= pack (url' <> name)
|
|
, "name" .= name
|
|
, "original" .= url ]
|