diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index e67e2ee..869dc06 100644 --- a/Handler/Haddock.hs +++ b/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| +
+ ^{widget} + + |] + +putUploadDocMapR :: Handler Html +putUploadDocMapR = getUploadDocMapR diff --git a/Handler/Package.hs b/Handler/Package.hs index a793f81..1661caf 100644 --- a/Handler/Package.hs +++ b/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 <- diff --git a/config/models b/config/models index 2c8cbc8..b8385d5 100644 --- a/config/models +++ b/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 diff --git a/config/routes b/config/routes index fa9507b..8463bc2 100644 --- a/config/routes +++ b/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 diff --git a/templates/package.hamlet b/templates/package.hamlet index 43048a7..2c961ef 100644 --- a/templates/package.hamlet +++ b/templates/package.hamlet @@ -95,6 +95,13 @@ $newline never #{renderEmail email} + $maybe (version, modules) <- mdocs +
+

Documentation for version #{version} +