Use Data.Text everywhere

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

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 ]

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

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
     }

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)
-  
+  AppSettings {..} <- settings
+  table            <- load urlTable
+
+  putStrLn ("Serving on " ++ unpack bindUrl)
+
+  when (bindPort == 443) (forkIO' $ runTLSRedirect bindHost)
+  runBreve tlsSetts bindPort (app bindUrl table)

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