From 404fd47e7ba3e5e977b3f27ff1fbe0cbbd4dad90 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 17 Apr 2014 19:50:01 +0300
Subject: [PATCH] Aliases

---
 Application.hs           |  2 ++
 Handler/Alias.hs         | 15 +++++++++++++++
 Handler/Aliases.hs       | 23 +++++++++++++++++++++++
 Handler/Profile.hs       | 11 ++++++++++-
 config/models            |  6 ++++++
 config/routes            |  2 ++
 stackage-server.cabal    |  2 ++
 templates/profile.hamlet | 15 +++++++++++++++
 templates/profile.lucius |  6 ++++++
 9 files changed, 81 insertions(+), 1 deletion(-)
 create mode 100644 Handler/Alias.hs
 create mode 100644 Handler/Aliases.hs

diff --git a/Application.hs b/Application.hs
index 7ff3954..3046e2b 100644
--- a/Application.hs
+++ b/Application.hs
@@ -43,6 +43,8 @@ import Handler.StackageIndex
 import Handler.StackageSdist
 import Handler.HackageViewIndex
 import Handler.HackageViewSdist
+import Handler.Aliases
+import Handler.Alias
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
diff --git a/Handler/Alias.hs b/Handler/Alias.hs
new file mode 100644
index 0000000..f0fb571
--- /dev/null
+++ b/Handler/Alias.hs
@@ -0,0 +1,15 @@
+module Handler.Alias where
+
+import Import
+import Data.Slug (Slug)
+
+handleAliasR :: Slug -> Slug -> [Text] -> Handler ()
+handleAliasR user name pieces = do
+    $logDebug $ tshow (user, name, pieces)
+    Entity _ (Alias _ _ setid) <- runDB $ do
+        Entity uid _ <- getBy404 $ UniqueHandle user
+        getBy404 $ UniqueAlias uid name
+    $logDebug $ "setid: " ++ tshow (setid, pieces)
+    case parseRoute ("stackage" : toPathPiece setid : pieces, []) of
+        Nothing -> notFound
+        Just route -> redirect (route :: Route App)
diff --git a/Handler/Aliases.hs b/Handler/Aliases.hs
new file mode 100644
index 0000000..11583e8
--- /dev/null
+++ b/Handler/Aliases.hs
@@ -0,0 +1,23 @@
+module Handler.Aliases where
+
+import Import
+import Data.Text (strip)
+
+putAliasesR :: Handler ()
+putAliasesR = do
+    uid <- requireAuthId
+    aliasesText <- runInputPost $ ireq textField "aliases"
+    aliases <- mapM (parseAlias uid) $ lines aliasesText
+    runDB $ do
+        deleteWhere [AliasUser ==. uid]
+        mapM_ insert aliases
+    setMessage "Aliases updated"
+    redirect ProfileR
+
+parseAlias :: UserId -> Text -> Handler Alias
+parseAlias uid t = maybe (invalidArgs ["Invalid alias: " ++ t]) return $ do
+    name <- fromPathPiece x
+    setid <- fromPathPiece y
+    return $ Alias uid name setid
+  where
+    (strip -> x, (strip . drop 1) -> y) = break (== ':') t
diff --git a/Handler/Profile.hs b/Handler/Profile.hs
index 6d37243..94e726c 100644
--- a/Handler/Profile.hs
+++ b/Handler/Profile.hs
@@ -21,10 +21,19 @@ getProfileR = do
             setMessage "Profile updated"
             redirect ProfileR
         _ -> return ()
-    emails <- runDB $ selectList [EmailUser ==. uid] [Asc EmailEmail]
+    (emails, aliases) <- runDB $ (,)
+        <$> selectList [EmailUser ==. uid] [Asc EmailEmail]
+        <*> selectList [AliasUser ==. uid] [Asc AliasName]
     defaultLayout $ do
         setTitle "Your Profile"
         $(widgetFile "profile")
 
+aliasToText :: Entity Alias -> Text
+aliasToText (Entity _ (Alias _ name target)) = concat
+    [ toPathPiece name
+    , ": "
+    , toPathPiece target
+    ]
+
 putProfileR :: Handler Html
 putProfileR = getProfileR
diff --git a/config/models b/config/models
index 42d043d..97a30f4 100644
--- a/config/models
+++ b/config/models
@@ -27,3 +27,9 @@ Uploaded
     version Version
     uploaded UTCTime
     UniqueUploaded name version
+
+Alias
+    user UserId
+    name Slug
+    target PackageSetIdent
+    UniqueAlias user name
diff --git a/config/routes b/config/routes
index 7232bcd..739e02b 100644
--- a/config/routes
+++ b/config/routes
@@ -14,3 +14,5 @@
 /stackage/#PackageSetIdent/package/#PackageNameVersion StackageSdistR GET
 /hackage-view/#HackageView/00-index.tar.gz HackageViewIndexR GET
 /hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET
+/aliases AliasesR PUT
+/alias/#Slug/#Slug/*Texts AliasR
diff --git a/stackage-server.cabal b/stackage-server.cabal
index e900d15..a6bbd9a 100644
--- a/stackage-server.cabal
+++ b/stackage-server.cabal
@@ -34,6 +34,8 @@ library
                      Handler.StackageSdist
                      Handler.HackageViewIndex
                      Handler.HackageViewSdist
+                     Handler.Aliases
+                     Handler.Alias
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
diff --git a/templates/profile.hamlet b/templates/profile.hamlet
index 6113317..0284a85 100644
--- a/templates/profile.hamlet
+++ b/templates/profile.hamlet
@@ -20,6 +20,21 @@ $else
         ^{userWidget}
     <button .btn>Update
 
+<h2>Aliases
+
+<form method=post action=@{AliasesR}?_method=PUT>
+    Format: alias name, package set ID
+    <textarea #aliases name=aliases>#{unlines $ map aliasToText aliases}
+    <button .btn>Update
+
+$if not $ null aliases
+    <dl>
+        $forall Entity _ alias <- aliases
+            <dt>#{aliasName alias}
+            <dd>
+                $with url <- AliasR (userHandle user) (aliasName alias) []
+                    <a href=@{url}>@{url}
+
 <h2>Security token
 
 <p>
diff --git a/templates/profile.lucius b/templates/profile.lucius
index 1550d97..9be676e 100644
--- a/templates/profile.lucius
+++ b/templates/profile.lucius
@@ -1,3 +1,9 @@
 .email > form {
     display: inline-block;
 }
+
+#aliases {
+    display: block;
+    width: 400px;
+    height: 200px;
+}