diff --git a/breve.cabal b/breve.cabal
--- a/breve.cabal
+++ b/breve.cabal
@@ -1,5 +1,5 @@
name: breve
-version: 0.2.0.0
+version: 0.3.0.0
synopsis: a url shortener
description:
@@ -15,8 +15,7 @@
category: Web
build-type: Simple
extra-source-files: README.md, LICENSE
-data-files: static/*.png, static/*.html, static/*.css,
- views/*.html
+data-files: static/*.png, static/*.css
cabal-version: >=1.10
source-repository head
@@ -27,13 +26,14 @@
main-is: Main.hs
hs-source-dirs: src
default-language: Haskell2010
- other-modules: Application, Breve.Common,
+ other-modules: Application, Views, Breve.Settings,
Breve.Generator, Breve.UrlTable
other-extensions: OverloadedStrings
- build-depends: base >=4.8 && <5.0,
- simple, wai, wai-extra, warp,
- aeson, bytestring, binary,
+ build-depends: base >=4.8 && <5.0, warp,
+ Spock, blaze-html, http-types,
+ wai, wai-middleware-static, wai-extra,
transformers, mtl,
+ text, aeson, bytestring, binary,
hashtables, cryptohash, random,
xdg-basedir, configurator, directory
ghc-options: -threaded -O2
diff --git a/src/Application.hs b/src/Application.hs
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -1,68 +1,74 @@
-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
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.Aeson hiding (json)
+import Data.Monoid
+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.HTTP.Types.Status
+import Network.Wai (Middleware)
+import Network.Wai.Middleware.Static
+import Network.Wai.Middleware.RequestLogger
-app :: (Application -> IO ()) -> IO ()
-app runner = do
- settings <- newAppSettings
- ServerSettings {..} <- newServerSettings
- table <- load urlTable
+logStr :: String -> ActionT IO ()
+logStr = liftIO . putStrLn
- static <- getDataFileName "static/"
- index <- getDataFileName "views/index.html"
- done <- getDataFileName "views/done.html"
- runner $ controllerApp settings $ do
- get "/" (render index ())
+serveStatic :: FilePath -> Middleware
+serveStatic = staticPolicy . addBase
- get "/:file" $ do
- file <- queryParam' "file"
- 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
+reply :: Status -> String -> ActionT IO ()
+reply code text = setStatus code >> render (message text)
- post "/" $ do
- form <- fst <$> parseForm
- case lookup "url" form of
- 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
- form <- fst <$> parseForm
- case lookup "url" form of
- Nothing -> respond badRequest
- Just url' -> do
- let url = BS.unpack url'
- name <- liftIO (insert table url)
- logStr (printf "Registered %s -> %s " url name)
- let json = object [ "link" .= (bindUrl ++ name)
- , "name" .= name
- , "original" .= url ]
- respond $ okHtml (encode json)
+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 ]
diff --git a/src/Breve/Common.hs b/src/Breve/Common.hs
deleted file mode 100644
--- a/src/Breve/Common.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}
-module Breve.Common where
-
-import Paths_breve (getDataFileName)
-
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad (when)
-import Text.Printf (printf)
-import System.Environment (lookupEnv)
-import System.Environment.XDG.BaseDir
-import System.Directory (doesFileExist)
-import Data.Configurator
-
-import Web.Simple.Templates
-import Network.Wai.Handler.Warp
-
-data ServerSettings = ServerSettings
- { bindHostname :: String
- , bindPort :: Int
- , bindUrl :: String
- , urlTable :: FilePath
- , warpSettings :: Settings
- }
-
-data AppSettings = AppSettings {}
-
-instance HasTemplates IO AppSettings where
- defaultLayout = do
- main <- liftIO (getDataFileName "static/main.html")
- Just <$> getTemplate main
-
-
-createEmptyIfMissing :: FilePath -> IO ()
-createEmptyIfMissing file = do
- exists <- doesFileExist file
- when (not exists) (writeFile file "")
-
-
-newAppSettings :: IO AppSettings
-newAppSettings = return AppSettings
-
-
-newServerSettings :: IO ServerSettings
-newServerSettings = do
- urlsPath <- getUserDataFile "breve" ""
- configPath <- getUserConfigFile "breve" ""
-
- config <- load [Required configPath]
- host <- lookupDefault "localhost" config "hostname"
- port <- lookupDefault 3000 config "port"
- urls <- lookupDefault urlsPath config "urltable"
-
- createEmptyIfMissing urls
-
- return ServerSettings
- { bindHostname = host
- , bindPort = port
- , bindUrl = if port == 80
- then printf "http://%s/" host
- else printf "http://%s:%d/" host port
- , urlTable = urls
- , warpSettings = setPort port defaultSettings
- }
diff --git a/src/Breve/Settings.hs b/src/Breve/Settings.hs
new file mode 100644
--- /dev/null
+++ b/src/Breve/Settings.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Breve.Settings where
+
+import Control.Monad (when)
+import System.Environment (lookupEnv)
+import System.Environment.XDG.BaseDir
+import System.Directory (doesFileExist)
+import Data.Configurator
+import Data.Monoid
+
+data AppSettings = AppSettings
+ { bindPort :: Int
+ , bindUrl :: String
+ , urlTable :: FilePath
+ }
+
+
+createEmptyIfMissing :: FilePath -> IO ()
+createEmptyIfMissing file = do
+ exists <- doesFileExist file
+ when (not exists) (writeFile file "")
+
+
+settings :: IO AppSettings
+settings = do
+ urlsPath <- getUserDataFile "breve" ""
+ configPath <- getUserConfigFile "breve" ""
+
+ config <- load [Required configPath]
+ host <- lookupDefault "localhost" config "hostname"
+ port <- lookupDefault 3000 config "port"
+ urls <- lookupDefault urlsPath config "urltable"
+
+ createEmptyIfMissing urls
+
+ let base = "http://" <> host
+ url = if port == 80
+ then base
+ else base <> ":" <> show port
+
+ return AppSettings
+ { bindPort = port
+ , bindUrl = url <> "/"
+ , urlTable = urls
+ }
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,14 +1,22 @@
-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
import Application
-import Breve.Common
+import Breve.Settings
+import Breve.UrlTable
-import Control.Applicative
-import Network.Wai.Handler.Warp
-import Network.Wai.Middleware.RequestLogger
+import Web.Spock.Safe
+import Network.Wai.Handler.Warp (run)
+runBreve :: Int -> SpockT IO () -> IO ()
+runBreve port app = spockAsApp (spockT id app) >>= run port
+
+
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)
+
diff --git a/src/Views.hs b/src/Views.hs
new file mode 100644
--- /dev/null
+++ b/src/Views.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Views where
+
+import Data.Text (Text)
+import Data.Text.Lazy (toStrict)
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+import Text.Blaze.Html5 as H
+import Text.Blaze.Html5.Attributes as A
+import qualified Web.Spock.Safe as S
+
+render :: Html -> S.ActionT IO ()
+render = S.html . toStrict . renderHtml
+
+done :: String -> Html
+done url = template $ do
+ "here's your new link: "
+ a ! href (toValue url) $ (toHtml url)
+
+index :: Html
+index = template $ do
+ H.form ! method "POST" $ do
+ "your url:"
+ input ! type_ "text" ! name "url"
+ input ! type_ "submit" ! value "go"
+
+message :: String -> Html
+message = template . toHtml
+
+template :: Html -> Html
+template fill =
+ docTypeHtml $ do
+ H.head $ do
+ H.title "breve: url shortener"
+ meta ! name "description" ! content "url shortener"
+ meta ! name "keywords" ! content "url, shortener"
+ meta ! name "author" ! content "Michele Guerini Rocco"
+ meta ! charset "utf-8"
+ link ! rel "stylesheet" ! href "main.css" ! type_ "text/css"
+ link ! rel "apple-touch-icon" ! href "icon-big.png"
+ link ! rel "icon" ! type_ "image/png" ! href "/icon-medium.png" ! sizes "96x96"
+ link ! rel "icon" ! type_ "image/png" ! href "/icon-small.png" ! sizes "16x16"
+ script ! src "https://cdn.rawgit.com/LeaVerou/prefixfree/gh-pages/prefixfree.min.js" $ mempty
+ body $ do
+ header $ do
+ h1 $ a ! href "/" $ "BREVE"
+ h2 "a url shortener"
+ H.div ! A.id "center" $ fill
+ footer $ do
+ "breve is open "
+ a ! href "https://github.com/rnhmjoj/breve" $ "source"
+ H.span "© Rnhmjoj"
diff --git a/static/main.css b/static/main.css
--- a/static/main.css
+++ b/static/main.css
@@ -47,6 +47,7 @@
background: transparent;
color: #776049;
padding: 0 2px;
+ margin: 0 .5em;
}
input[type="submit"] {
diff --git a/static/main.html b/static/main.html
deleted file mode 100644
--- a/static/main.html
+++ /dev/null
@@ -1,26 +0,0 @@
-
-
-
- breve: url shortener
-
-
-
-
-
-
-
-
-
-
-
-
- $yield$
-
-
-
diff --git a/views/done.html b/views/done.html
deleted file mode 100644
--- a/views/done.html
+++ /dev/null
@@ -1,1 +0,0 @@
-here's your new link: $link$
diff --git a/views/index.html b/views/index.html
deleted file mode 100644
--- a/views/index.html
+++ /dev/null
@@ -1,4 +0,0 @@
-