From 0401ccd128521145b513333583d593312d9d78d5 Mon Sep 17 00:00:00 2001 From: rnhmjoj Date: Tue, 11 Aug 2015 04:02:10 +0200 Subject: [PATCH] Use Data.Text everywhere --- breve.cabal | 2 +- src/Application.hs | 33 ++++++++++++++------------------- src/Breve/Generator.hs | 13 +++++++------ src/Breve/Settings.hs | 19 +++++++++++-------- src/Main.hs | 32 ++++++++++++++++++++++---------- src/Views.hs | 4 ++-- 6 files changed, 57 insertions(+), 46 deletions(-) diff --git a/breve.cabal b/breve.cabal index 12a0a91..b23b5b1 100644 --- a/breve.cabal +++ b/breve.cabal @@ -33,7 +33,7 @@ executable breve Spock, blaze-html, http-types, wai, wai-middleware-static, wai-extra, transformers, mtl, - text, aeson, bytestring, binary, + text, text-format, aeson, bytestring, binary, hashtables, cryptohash, random, xdg-basedir, configurator, directory ghc-options: -threaded -O2 diff --git a/src/Application.hs b/src/Application.hs index 39640eb..6529625 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -6,13 +6,11 @@ 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 Control.Monad.IO.Class (liftIO) +import Data.Aeson hiding (json) +import Data.Text (Text) +import qualified Data.Text.Format as F import Web.Spock.Safe import Network.HTTP.Types.Status @@ -20,15 +18,12 @@ 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 :: Status -> Text -> ActionT IO () reply code text = setStatus code >> render (message text) @@ -46,29 +41,29 @@ app url' table = do case url of Nothing -> reply status404 "404: does not exist" Just url -> do - logStr (printf "Resolved %s -> %s" name url) - redirect (pack url) + F.print "Resolved {} -> {} " (name, url) + redirect url post "/" $ do url <- param "url" - case unpack <$> url of + case url of Nothing -> reply status400 "400: bad request" Just url -> do name <- liftIO (insert table url) - logStr (printf "Registered %s -> %s " url name) + F.print "Registered {} -> {} " (url, name) let link = url' <> name render (done link) post "api" $ do url <- param "url" - case unpack <$> url of + case url of Nothing -> do setStatus status400 - json $ object [ "error" .= pack "bad request" - , "msg" .= pack "missing url field" ] + json $ object [ "error" .= ("bad request" :: Text ) + , "msg" .= ("missing url field" :: Text ) ] Just url -> do name <- liftIO (insert table url) - logStr (printf "Registered %s -> %s " url name) - json $ object [ "link" .= pack (url' <> name) + F.print "Registered {} -> {} " (url, name) + json $ object [ "link" .= (url' <> name) , "name" .= name , "original" .= url ] diff --git a/src/Breve/Generator.hs b/src/Breve/Generator.hs index d322093..5a00861 100644 --- a/src/Breve/Generator.hs +++ b/src/Breve/Generator.hs @@ -1,4 +1,4 @@ -module Breve.Generator +module Breve.Generator ( nameHash , intHash , Name @@ -9,11 +9,12 @@ import Control.Monad.State import System.Random import Crypto.Hash.SHA256 (hash) import Data.Binary (decode) -import Data.ByteString.Char8 (pack) import Data.ByteString.Lazy (fromStrict) +import Data.Text (Text, pack) +import Data.Text.Encoding (encodeUtf8) -type Name = String -type Url = String +type Name = Text +type Url = Text -- Choose a random element of a list choice :: [a] -> State StdGen a @@ -22,14 +23,14 @@ choice xs = (xs !!) <$> randomSt (0, length xs - 1) -- Generate a random phonetic string word :: State StdGen Name -word = replicateM 10 letter where +word = pack <$> replicateM 10 letter where vowels = "aeiou" consonants = "bcdfghjklmnpqrstvwxyz" letter = choice [vowels, consonants] >>= choice -- SHA256 hash to seed a generator intHash :: Url -> Int -intHash = decode . fromStrict . hash . pack +intHash = decode . fromStrict . hash . encodeUtf8 -- Assign a unique name to the url nameHash :: Url -> Name diff --git a/src/Breve/Settings.hs b/src/Breve/Settings.hs index c9fa2cf..72e73a5 100644 --- a/src/Breve/Settings.hs +++ b/src/Breve/Settings.hs @@ -6,13 +6,16 @@ import System.Environment (lookupEnv) import System.Environment.XDG.BaseDir import System.Directory (doesFileExist) import Data.Configurator +import Data.Monoid +import Data.Text (Text, pack) import Network.Wai.Handler.WarpTLS (tlsSettings, TLSSettings) data AppSettings = AppSettings - { bindPort :: Int - , bindUrl :: String - , urlTable :: FilePath - , tlsSetts :: TLSSettings + { bindHost :: Text + , bindPort :: Int + , bindUrl :: Text + , urlTable :: FilePath + , tlsSetts :: TLSSettings } @@ -27,7 +30,7 @@ settings = do urlsPath <- getUserDataFile "breve" "" configPath <- getUserConfigFile "breve" "" - config <- load [Required configPath] + config <- load [Required configPath] host <- lookupDefault "localhost" config "hostname" port <- lookupDefault 3000 config "port" cert <- lookupDefault "/usr/share/tls/breve.crt" config "cert" @@ -36,14 +39,14 @@ settings = do createEmptyIfMissing urls - let base = "https://" ++ host + let base = "https://" <> host url = if port == 443 then base - else base ++ ":" ++ show port + else base <> ":" <> pack (show port) return AppSettings { bindPort = port - , bindUrl = url ++ "/" + , bindUrl = url <> "/" , urlTable = urls , tlsSetts = tlsSettings cert key } diff --git a/src/Main.hs b/src/Main.hs index eedefa3..2f35bd1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,25 +1,37 @@ -{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} import Application import Breve.Settings import Breve.UrlTable +import Data.Text (Text, unpack) +import Control.Concurrent (forkIO) +import Control.Monad + import Web.Spock.Safe import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings) -import Network.Wai.Handler.Warp (defaultSettings, setPort) +import Network.Wai.Handler.Warp (run, defaultSettings, setPort) runBreve :: TLSSettings -> Int -> SpockT IO () -> IO () runBreve tls port spock = spockAsApp (spockT id spock) >>= runTLS tls settings where settings = setPort port defaultSettings + +runTLSRedirect :: Text -> IO () +runTLSRedirect = spockAsApp . spockT id . toTLS >=> run 80 + + +forkIO' :: IO () -> IO () +forkIO' = fmap (const ()) . forkIO + + main :: IO () main = do - AppSettings { bindUrl - , bindPort - , urlTable - , tlsSetts } <- settings - table <- load urlTable - putStrLn ("Serving on " ++ bindUrl) - runBreve tlsSetts bindPort (app bindUrl table) - \ No newline at end of file + AppSettings {..} <- settings + table <- load urlTable + + putStrLn ("Serving on " ++ unpack bindUrl) + + when (bindPort == 443) (forkIO' $ runTLSRedirect bindHost) + runBreve tlsSetts bindPort (app bindUrl table) \ No newline at end of file diff --git a/src/Views.hs b/src/Views.hs index da20d1e..e4fbbd0 100644 --- a/src/Views.hs +++ b/src/Views.hs @@ -12,7 +12,7 @@ import qualified Web.Spock.Safe as S render :: Html -> S.ActionT IO () render = S.html . toStrict . renderHtml -done :: String -> Html +done :: Text -> Html done url = template $ do "here's your new link: " a ! href (toValue url) $ (toHtml url) @@ -24,7 +24,7 @@ index = template $ do input ! type_ "text" ! name "url" input ! type_ "submit" ! value "go" -message :: String -> Html +message :: Text -> Html message = template . toHtml template :: Html -> Html