Aliases

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

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)

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

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

config/models

@@ -27,3 +27,9 @@ Uploaded
     version Version
     uploaded UTCTime
     UniqueUploaded name version
+
+Alias
+    user UserId
+    name Slug
+    target PackageSetIdent
+    UniqueAlias user name

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

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

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>

templates/profile.lucius

@@ -1,3 +1,9 @@
 .email > form {
     display: inline-block;
 }
+
+#aliases {
+    display: block;
+    width: 400px;
+    height: 200px;
+}