Haddock uploading/display

Application.hs

@@ -52,6 +52,7 @@ import           Handler.Aliases
 import           Handler.Alias
 import           Handler.Progress
 import           Handler.System
+import           Handler.Haddock
 
 -- 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
@@ -133,6 +134,9 @@ makeFoundation useEcho conf = do
                     <*> pure Nothing
                 return $ cachedS3Store root creds bucket prefix manager
 
+    let haddockRootDir' = "/tmp/stackage-server-haddocks"
+    unpacker <- createHaddockUnpacker haddockRootDir' blobStore'
+
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App
             { settings = conf
@@ -145,6 +149,8 @@ makeFoundation useEcho conf = do
             , blobStore = blobStore'
             , progressMap = progressMap'
             , nextProgressKey = nextProgressKey'
+            , haddockRootDir = haddockRootDir'
+            , haddockUnpacker = unpacker
             }
 
     -- Perform database migration using our application's logging settings.

Foundation.hs

@@ -35,6 +35,12 @@ data App = App
     , blobStore :: !(BlobStore StoreKey)
     , progressMap :: !(IORef (IntMap Progress))
     , nextProgressKey :: !(IORef Int)
+    , haddockRootDir :: !FilePath
+    , haddockUnpacker :: !(PackageSetIdent -> IO ())
+    -- ^ We have a dedicated thread so that (1) we don't try to unpack too many
+    -- things at once, (2) we never unpack the same thing twice at the same
+    -- time, and (3) so that even if the client connection dies, we finish the
+    -- unpack job.
     }
 
 data Progress = ProgressWorking !Text
@@ -136,6 +142,7 @@ instance Yesod App where
     makeLogger = return . appLogger
 
     maximumContentLength _ (Just UploadStackageR) = Just 50000000
+    maximumContentLength _ (Just UploadHaddockR{}) = Just 50000000
     maximumContentLength _ _ = Just 2000000
 
 -- How to run database actions.

Handler/Haddock.hs

@@ -0,0 +1,88 @@
+module Handler.Haddock where
+
+import Import
+import Data.BlobStore
+import Filesystem (removeTree, isDirectory, createTree, isFile)
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Chan
+import System.IO.Temp (withSystemTempFile)
+import Control.Exception (mask)
+import System.Process (createProcess, proc, cwd, waitForProcess)
+import System.Exit (ExitCode (ExitSuccess))
+import Network.Mime (defaultMimeLookup)
+
+form :: Form FileInfo
+form = renderDivs $ areq fileField "tarball containing docs"
+    { fsName = Just "tarball"
+    } Nothing
+
+getUploadHaddockR, putUploadHaddockR :: PackageSetIdent -> Handler Html
+getUploadHaddockR ident = do
+    uid <- requireAuthId
+    Entity sid Stackage {..} <- runDB $ getBy404 $ UniqueStackage ident
+    unless (uid == stackageUser) $ permissionDenied "You do not control this snapshot"
+    ((res, widget), enctype) <- runFormPost form
+    case res of
+        FormSuccess fileInfo -> do
+            fileSource fileInfo $$ storeWrite (HaddockBundle ident)
+            runDB $ update sid [StackageHasHaddocks =. True]
+            master <- getYesod
+            getHaddockDir ident >>= liftIO . void . tryIO . removeTree
+            setMessage "Haddocks uploaded"
+            redirect $ StackageHomeR ident
+        _ -> defaultLayout $ do
+            setTitle "Upload Haddocks"
+            $(widgetFile "upload-haddock")
+
+putUploadHaddockR = getUploadHaddockR
+
+getHaddockR :: PackageSetIdent -> [Text] -> Handler ()
+getHaddockR ident rest = do
+    mapM_ sanitize rest
+    dir <- getHaddockDir ident
+    master <- getYesod
+    liftIO $ unlessM (isDirectory dir) $ haddockUnpacker master ident
+    let fp = mconcat $ dir : map fpFromText rest
+
+    whenM (liftIO $ isDirectory fp)
+        $ redirect $ HaddockR ident $ rest ++ ["index.html"]
+    unlessM (liftIO $ isFile fp) notFound
+
+    let mime = defaultMimeLookup $ fpToText $ filename fp
+    sendFile mime $ fpToString fp
+  where
+    sanitize p
+        | ("/" `isInfixOf` p) || p `member` (asHashSet $ setFromList ["", ".", ".."]) =
+            permissionDenied "Invalid request"
+        | otherwise = return ()
+
+createHaddockUnpacker :: FilePath -- ^ haddock root
+                      -> BlobStore StoreKey
+                      -> IO (PackageSetIdent -> IO ())
+createHaddockUnpacker root store = do
+    chan <- newChan
+
+    mask $ \restore -> void $ forkIO $ forever $ do
+        (ident, res) <- readChan chan
+        try (restore $ go ident) >>= putMVar res
+    return $ \ident -> do
+        res <- newEmptyMVar
+        writeChan chan (ident, res)
+        takeMVar res >>= either (throwM . asSomeException) return
+  where
+    go ident = unlessM (isDirectory dir) $
+               withSystemTempFile "haddock-bundle.tar.xz" $ \tempfp temph -> do
+        withAcquire (storeRead' store (HaddockBundle ident)) $ \msrc ->
+            case msrc of
+                Nothing -> error "No haddocks exist for that snapshot"
+                Just src -> src $$ sinkHandle temph
+        hClose temph
+        createTree dir
+        (Nothing, Nothing, Nothing, ph) <- createProcess
+            (proc "tar" ["xf", tempfp])
+                { cwd = Just $ fpToString dir
+                }
+        ec <- waitForProcess ph
+        if ec == ExitSuccess then return () else throwM ec
+      where
+        dir = root </> fpFromText (toPathPiece ident)

Handler/StackageHome.hs

@@ -6,10 +6,11 @@ import Data.Time (FormatTime)
 
 getStackageHomeR :: PackageSetIdent -> Handler Html
 getStackageHomeR ident = do
-    (stackage, user) <- runDB $ do
+    muid <- maybeAuthId
+    stackage <- runDB $ do
         Entity _ stackage <- getBy404 $ UniqueStackage ident
-        user <- get404 $ stackageUser stackage
-        return (stackage, user)
+        return stackage
+    let isOwner = muid == Just (stackageUser stackage)
 
     hasBundle <- storeExists $ SnapshotBundle ident
     let minclusive =

Handler/UploadStackage.hs

@@ -91,6 +91,7 @@ putUploadStackageR = do
                         , stackageUploaded = now
                         , stackageTitle = "Untitled Stackage"
                         , stackageDesc = "No description provided"
+                        , stackageHasHaddocks = False
                         }
 
                 -- Evil lazy I/O thanks to tar package

Import.hs

@@ -10,3 +10,8 @@ import Settings.Development as Import
 import Settings.StaticFiles as Import
 import Types as Import
 import Yesod.Auth as Import
+
+getHaddockDir :: PackageSetIdent -> Handler FilePath
+getHaddockDir ident = do
+    master <- getYesod
+    return $ haddockRootDir master </> fpFromText (toPathPiece ident)

Types.hs

@@ -43,6 +43,7 @@ data StoreKey = HackageCabal !PackageName !Version
               | HackageViewSdist !HackageView !PackageName !Version
               | HackageViewIndex !HackageView
               | SnapshotBundle !PackageSetIdent
+              | HaddockBundle !PackageSetIdent
     deriving (Show, Eq, Ord, Typeable)
 
 instance ToPath StoreKey where
@@ -76,6 +77,10 @@ instance ToPath StoreKey where
         [ "bundle"
         , toPathPiece ident ++ ".tar.gz"
         ]
+    toPath (HaddockBundle ident) =
+        [ "haddock"
+        , toPathPiece ident ++ ".tar.xz"
+        ]
 instance BackupToS3 StoreKey where
     shouldBackup HackageCabal{} = False
     shouldBackup HackageSdist{} = False
@@ -85,6 +90,7 @@ instance BackupToS3 StoreKey where
     shouldBackup HackageViewSdist{} = False
     shouldBackup HackageViewIndex{} = False
     shouldBackup SnapshotBundle{} = True
+    shouldBackup HaddockBundle{} = True
 
 newtype HackageRoot = HackageRoot { unHackageRoot :: Text }
     deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup)

config/models

@@ -20,6 +20,7 @@ Stackage
     uploaded UTCTime
     title Text
     desc Text
+    hasHaddocks Bool default=false
     UniqueStackage ident
 
 Uploaded

config/routes

@@ -10,6 +10,7 @@
 /email/#EmailId EmailR DELETE
 /reset-token ResetTokenR POST
 /upload UploadStackageR GET PUT
+/upload-haddock/#PackageSetIdent UploadHaddockR GET PUT
 /stackage/#PackageSetIdent StackageHomeR GET
 /stackage/#PackageSetIdent/metadata StackageMetadataR GET
 /stackage/#PackageSetIdent/cabal.config StackageCabalConfigR GET
@@ -22,3 +23,4 @@
 /alias/#Slug/#Slug/*Texts AliasR
 /progress/#Int ProgressR GET
 /system SystemR GET
+/haddock/#PackageSetIdent/*Texts HaddockR GET

stackage-server.cabal

@@ -41,6 +41,7 @@ library
                      Handler.Alias
                      Handler.Progress
                      Handler.System
+                     Handler.Haddock
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
@@ -128,6 +129,7 @@ library
                  , process
                  , old-locale
                  , th-lift
+                 , mime-types
 
 executable         stackage-server
     if flag(library-only)

templates/stackage-home.hamlet

@@ -17,6 +17,15 @@ $newline never
            <span>
                <a href=@{StackageCabalConfigR ident} title="If you want to stick with upstream Hackage but get a stable package set">
                    \cabal.config
+           $if stackageHasHaddocks stackage
+               <span .separator>
+               <span>
+                   <a href=@{HaddockR ident []}>Haddocks
+    $if isOwner
+        <p>
+            You are the owner of this snapshot. You can #
+            <a href=@{UploadHaddockR ident}>upload haddocks#
+            .
     <p>
         <pre>
             remote-repo: stackage:@{StackageHomeR ident}

templates/upload-haddock.hamlet

@@ -0,0 +1,13 @@
+<div .container>
+    <h1>Upload Haddocks
+
+    <p>
+        <a href=@{StackageHomeR ident}>Return to snapshot
+
+    $if stackageHasHaddocks
+        <div .alert .alert-warning>You have already uploaded Haddocks. Uploading against will delete the old contents.
+
+    <form method=POST action=@{UploadHaddockR ident}?_method=PUT enctype=#{enctype}>
+        ^{widget}
+        <div>
+            <button .btn>Upload