diff --git a/Application.hs b/Application.hs index 14072b2..3362dce 100644 --- a/Application.hs +++ b/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. diff --git a/Foundation.hs b/Foundation.hs index 20b7961..99bcdf0 100644 --- a/Foundation.hs +++ b/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. diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs new file mode 100644 index 0000000..b60ee44 --- /dev/null +++ b/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) diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index c6f0b9a..e768675 100644 --- a/Handler/StackageHome.hs +++ b/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 = diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index 9faf402..0292265 100644 --- a/Handler/UploadStackage.hs +++ b/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 diff --git a/Import.hs b/Import.hs index d2deca4..14959dd 100644 --- a/Import.hs +++ b/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) diff --git a/Types.hs b/Types.hs index 3d442f9..9b5e135 100644 --- a/Types.hs +++ b/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) diff --git a/config/models b/config/models index 7181535..f4e7167 100644 --- a/config/models +++ b/config/models @@ -20,6 +20,7 @@ Stackage uploaded UTCTime title Text desc Text + hasHaddocks Bool default=false UniqueStackage ident Uploaded diff --git a/config/routes b/config/routes index bb2bed0..f62745c 100644 --- a/config/routes +++ b/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 diff --git a/stackage-server.cabal b/stackage-server.cabal index 66d7579..0b139a9 100644 --- a/stackage-server.cabal +++ b/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) diff --git a/templates/stackage-home.hamlet b/templates/stackage-home.hamlet index 2c3052d..370d42e 100644 --- a/templates/stackage-home.hamlet +++ b/templates/stackage-home.hamlet @@ -17,6 +17,15 @@ $newline never \cabal.config + $if stackageHasHaddocks stackage + + + Haddocks + $if isOwner +

+ You are the owner of this snapshot. You can # + upload haddocks# + . 

             remote-repo: stackage:@{StackageHomeR ident}
diff --git a/templates/upload-haddock.hamlet b/templates/upload-haddock.hamlet
new file mode 100644
index 0000000..72cfdce
--- /dev/null
+++ b/templates/upload-haddock.hamlet
@@ -0,0 +1,13 @@
+

+    
Upload Haddocks
+
+    

+        Return to snapshot
+
+    $if stackageHasHaddocks
+        
You have already uploaded Haddocks. Uploading against will delete the old contents.
+
+    

+        ^{widget}
+        

+