breve 0.4.0.0 → 0.4.1.0
raw patch · 6 files changed
+69/−47 lines, 6 files
Files
- breve.cabal +1/−1
- src/Application.hs +25/−20
- src/Breve/Generator.hs +7/−6
- src/Breve/Settings.hs +13/−9
- src/Main.hs +21/−9
- src/Views.hs +2/−2
breve.cabal view
@@ -1,5 +1,5 @@ name: breve-version: 0.4.0.0+version: 0.4.1.0 synopsis: a url shortener description:
src/Application.hs view
@@ -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
src/Breve/Generator.hs view
@@ -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
src/Breve/Settings.hs view
@@ -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 }
src/Main.hs view
@@ -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)-
src/Views.hs view
@@ -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