Support doc maps

Handler/Haddock.hs

@@ -18,6 +18,9 @@ import Crypto.Hash (Digest, SHA1)
 import qualified Filesystem.Path.CurrentOS as F
 import Data.Slug (SnapSlug)
 import qualified Data.Text as T
+import Data.Slug (unSlug)
+import qualified Data.Yaml as Y
+import Data.Aeson (withObject)
 
 form :: Form FileInfo
 form = renderDivs $ areq fileField "tarball containing docs"
@@ -288,3 +291,51 @@ createHaddockUnpacker root store runDB' = do
                                 ]
                                 [PackageHasHaddocks =. True]
                             )
+
+data DocInfo = DocInfo Version (Map Text [Text])
+instance FromJSON DocInfo where
+    parseJSON = withObject "DocInfo" $ \o -> DocInfo
+        <$> (Version <$> o .: "version")
+        <*> o .: "modules"
+
+getUploadDocMapR :: Handler Html
+getUploadDocMapR = do
+    uid <- requireAuthIdOrToken
+    user <- runDB $ get404 uid
+    extra <- getExtra
+    when (unSlug (userHandle user) `notMember` adminUsers extra)
+        $ permissionDenied "Must be an administrator"
+
+    ((res, widget), enctype) <- runFormPostNoToken $ renderDivs $ (,)
+        <$> areq
+            fileField
+            "YAML file with map" { fsName = Just "docmap" }
+            Nothing
+        <*> areq textField "Stackage ID" { fsName = Just "snapshot" } Nothing
+    case res of
+        FormSuccess (fi, snapshot) -> do
+            Entity sid stackage <-
+                runDB $ getBy404 $ UniqueStackage $ PackageSetIdent snapshot
+            bs <- fileSource fi $$ foldC
+            case Y.decodeEither bs of
+                Left e -> invalidArgs [pack e]
+                Right m0 -> do
+                    now <- liftIO getCurrentTime
+                    render <- getUrlRender
+                    runDB $ forM_ (mapToList $ asMap m0) $ \(package, DocInfo version ms) -> do
+                        did <- insert $ Docs (PackageName package) version now
+                        forM_ (mapToList ms) $ \(name, pieces) -> do
+                            let url = render $ HaddockR (stackageSlug stackage) pieces
+                            insert_ $ Module did name url
+                    setMessage "Doc map complete"
+                    redirect UploadDocMapR
+        _ -> defaultLayout $ do
+            setTitle "Upload doc map"
+            [whamlet|
+                <form method=post action=?_method=PUT enctype=#{enctype}>
+                    ^{widget}
+                    <input type=submit .btn value="Set document map">
+            |]
+
+putUploadDocMapR :: Handler Html
+putUploadDocMapR = getUploadDocMapR

Handler/Package.hs

@@ -23,7 +23,8 @@ getPackageR pn = do
         haddocksLink ident version =
             HaddockR ident [concat [toPathPiece pn, "-", toPathPiece version]]
     muid <- maybeAuthId
-    (packages, downloads, recentDownloads, nLikes, liked, Entity _ metadata, revdeps') <- runDB $ do
+    (packages, downloads, recentDownloads, nLikes, liked,
+      Entity _ metadata, revdeps', mdocs) <- runDB $ do
         packages <- fmap (map reformat) $ E.select $ E.from $ \(p, s) -> do
             E.where_ $ (p ^. PackageStackage E.==. s ^. StackageId)
                    &&. (p ^. PackageName' E.==. E.val pn)
@@ -46,6 +47,12 @@ getPackageR pn = do
             E.orderBy [E.asc $ dep ^. DependencyUser]
             return $ dep ^. DependencyUser
 
+        mdocsent <- selectFirst [DocsName ==. pn] [Desc DocsUploaded]
+        mdocs <- forM mdocsent $ \(Entity docsid (Docs _ version _)) -> (,)
+            <$> pure version
+            <*> (map entityVal <$>
+                 selectList [ModuleDocs ==. docsid] [Asc ModuleName])
+
         return ( packages
                , downloads
                , recentDownloads
@@ -53,6 +60,7 @@ getPackageR pn = do
                , liked
                , metadata
                , map E.unValue revdeps'
+               , mdocs
                )
 
     myTags <-

config/models

@@ -88,6 +88,16 @@ Metadata
 
     UniqueMetadata name
 
+Docs
+    name PackageName
+    version Version
+    uploaded UTCTime
+Module
+    docs DocsId
+    name Text
+    url Text
+    UniqueModule docs name
+
 Dependency
     dep PackageName
     user PackageName

config/routes

@@ -12,6 +12,7 @@
 /reset-token ResetTokenR POST
 /upload UploadStackageR GET PUT
 /upload-haddock/#Text UploadHaddockR GET PUT
+/upload-doc-map UploadDocMapR GET PUT
 
 /stackage/#PackageSetIdent/*Texts OldStackageR GET
 

templates/package.hamlet

@@ -95,6 +95,13 @@ $newline never
                                     <a href="mailto:#{renderEmail email}">
                                         #{renderEmail email}
 
+            $maybe (version, modules) <- mdocs
+                <div .docs>
+                    <p>Documentation for version #{version}
+                    <ul>
+                        $forall Module _ name url <- modules
+                            <li>
+                                <a href=#{url}>#{name}
             <div .dependencies>
                 Depends on
                 <div .dep-list>