breve 0.2.0.0 → 0.3.0.0
raw patch · 10 files changed
+179/−161 lines, 10 filesdep +Spockdep +blaze-htmldep +http-typesdep −simple
Dependencies added: Spock, blaze-html, http-types, text, wai-middleware-static
Dependencies removed: simple
Files
- breve.cabal +7/−7
- src/Application.hs +59/−53
- src/Breve/Common.hs +0/−63
- src/Breve/Settings.hs +45/−0
- src/Main.hs +15/−7
- src/Views.hs +52/−0
- static/main.css +1/−0
- static/main.html +0/−26
- views/done.html +0/−1
- views/index.html +0/−4
breve.cabal view
@@ -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
src/Application.hs view
@@ -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 ]
− src/Breve/Common.hs
@@ -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- }
+ src/Breve/Settings.hs view
@@ -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+ }
src/Main.hs view
@@ -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)+
+ src/Views.hs view
@@ -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"
static/main.css view
@@ -47,6 +47,7 @@ background: transparent; color: #776049; padding: 0 2px;+ margin: 0 .5em; } input[type="submit"] {
− static/main.html
@@ -1,26 +0,0 @@-<!DOCTYPE html>-<html>- <head>- <title>breve: url shortener</title>- <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"></script>- </head>- <body>- <header>- <h1><a href="/">BREVE</a></h1>- <h2>a url shortener</h2>- </header>- <div id="center">$yield$</div>- <footer>- breve is open <a href="https://github.com/rnhmjoj/breve">source</a>- <span>© Rnhmjoj</span>- </footer>- </body>-</html>
− views/done.html
@@ -1,1 +0,0 @@-here's your new link: <a href="$link$">$link$</a>
− views/index.html
@@ -1,4 +0,0 @@-<form method="POST">- your url: <input type="text" name="url">- <input type="submit" value="go">-</form>