diff --git a/breve.cabal b/breve.cabal --- a/breve.cabal +++ b/breve.cabal @@ -1,5 +1,5 @@ name: breve -version: 0.4.0.0 +version: 0.4.1.0 synopsis: a url shortener description: diff --git a/src/Application.hs b/src/Application.hs --- a/src/Application.hs +++ b/src/Application.hs @@ -6,13 +6,11 @@ import Paths_breve (getDataFileName) import Views +import Data.Monoid 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 Data.Text (Text) +import qualified Data.Text.IO as T import Web.Spock.Safe import Network.HTTP.Types.Status @@ -20,18 +18,19 @@ 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) +logStr :: Text -> ActionT IO () +logStr = liftIO . T.putStrLn + + app :: Url -> UrlTable -> SpockT IO () app url' table = do static <- liftIO (getDataFileName "static/") @@ -46,29 +45,35 @@ case url of Nothing -> reply status404 "404: does not exist" Just url -> do - logStr (printf "Resolved %s -> %s" name url) - redirect (pack url) + logStr ("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) - let link = url' <> name - render (done link) + logStr ("Registered " <> url <> " -> " <> name) + render (done $ url' <> name) 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) + logStr ("Registered " <> url <> " -> " <> name) + json $ object [ "link" .= (url' <> name) , "name" .= name , "original" .= url ] + + +toTLS :: Text -> SpockT IO () +toTLS host = do + get var (redirect . new) + get "/" (redirect $ new "") + where new url = "https://" <> host <> "/" <> url diff --git a/src/Breve/Generator.hs b/src/Breve/Generator.hs --- 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 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 @@ -- 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 --- a/src/Breve/Settings.hs +++ b/src/Breve/Settings.hs @@ -6,13 +6,16 @@ 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 @@ 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,15 @@ 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 ++ "/" + { bindHost = host + , bindPort = port + , bindUrl = url <> "/" , urlTable = urls , tlsSetts = tlsSettings cert key } diff --git a/src/Main.hs b/src/Main.hs --- 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) + AppSettings {..} <- settings + table <- load urlTable + + when (bindPort == 443) (forkIO' $ runTLSRedirect bindHost) + + putStrLn ("Serving on " ++ unpack bindUrl) runBreve tlsSetts bindPort (app bindUrl table) - diff --git a/src/Views.hs b/src/Views.hs --- a/src/Views.hs +++ b/src/Views.hs @@ -12,7 +12,7 @@ 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 @@ input ! type_ "text" ! name "url" input ! type_ "submit" ! value "go" -message :: String -> Html +message :: Text -> Html message = template . toHtml template :: Html -> Html