Canonicalize destination URLs.

Ryan Trinkle · Ryan Trinkle · commit 9b4ec9c8ccc6 · 2013-11-15T10:35:07.000-05:00
diff --git 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
@@ -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"
 
