diff --git a/memoise.cabal b/memoise.cabal index 3de42e8..e022889 100644 --- a/memoise.cabal +++ b/memoise.cabal @@ -1,5 +1,5 @@ Name: memoise -Version: 0.9 +Version: 0.10 License: BSD3 Author: Ryan Trinkle Maintainer: ryan.trinkle@gmail.com @@ -21,6 +21,7 @@ Executable memoise , heist >= 0.12 && < 0.13 , lens >= 3.9 && < 3.10 , text >= 0.11 && < 0.12 + , network >= 2.4 && < 2.5 , snaplet-postgresql-simple >= 0.4 && < 0.5 GHC-options: -threaded -O2 Extensions: OverloadedStrings diff --git a/src/Main.hs b/src/Main.hs index e527c6c..9118964 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -10,6 +10,7 @@ import Data.Text.Encoding import Data.Monoid import Heist import Heist.Interpreted +import Network.URI hiding (query) data Memoise = Memoise { _heist :: Snaplet (Heist Memoise) @@ -24,8 +25,17 @@ instance HasHeist Memoise where instance HasPostgres (Handler Memoise Memoise) where getPostgresState = with db get -getUrlId :: Text -> Handler Memoise Memoise Integer -getUrlId url = do +canonicalizeUrl :: Text -> Maybe URI +canonicalizeUrl rawUrl = + let url = unpack rawUrl + url' = if isAbsoluteURI url + then url + else "http://" <> url + in parseURI $ normalizeCase $ normalizePathSegments $ normalizeEscape url' + +getUrlId :: URI -> Handler Memoise Memoise Integer +getUrlId uri = do + let url = showT uri existingResults <- query "SELECT id FROM urls WHERE url = ?" (Only url) case existingResults of (Only urlId) : _ -> return urlId @@ -38,8 +48,11 @@ indexHandler = do mUrl <- getParam "url" case mUrl of Just url -> do - urlId <- getUrlId $ decodeUtf8 url - mainTextboxContents .= Just ("http://memoi.se/" <> showT urlId) + case canonicalizeUrl (decodeUtf8 url) of + Just uri -> do + urlId <- getUrlId uri + mainTextboxContents .= Just ("http://memoi.se/" <> showT urlId) + Nothing -> mainTextboxContents .= Just "Invalid URL" render "index" Nothing -> render "index"