Blob storage and downloading from Hackage

.gitignore

@@ -12,3 +12,4 @@ yesod-devel/
 cabal.sandbox.config
 .DS_Store
 *.swp
+/dev-blob-store/

Application.hs

@@ -16,13 +16,16 @@ import Network.Wai.Middleware.RequestLogger
 import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
 import qualified Database.Persist
 import Control.Monad.Logger (runLoggingT)
+import Control.Monad.Reader (runReaderT)
 import Control.Concurrent (forkIO, threadDelay)
-import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
+import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
 import Network.Wai.Logger (clockDateCacher)
 import Yesod.Core.Types (loggerSet, Logger (Logger))
 import qualified System.Random.MWC as MWC
 import qualified Network.Wai as Wai
 import Network.Wai.Middleware.MethodOverride (methodOverride)
+import Data.BlobStore (fileStore)
+import Data.Hackage
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -30,6 +33,7 @@ import Handler.Home
 import Handler.Profile
 import Handler.Email
 import Handler.ResetToken
+import Handler.HackageSdist
 
 -- 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
@@ -83,6 +87,7 @@ makeFoundation conf = do
     let updateLoop = do
             threadDelay 1000000
             updater
+            flushLogStr loggerSet' -- FIXME include upstream!
             updateLoop
     _ <- forkIO updateLoop
 
@@ -97,6 +102,9 @@ makeFoundation conf = do
             , persistConfig = dbconf
             , appLogger = logger
             , genIO = gen
+            , blobStore =
+                case storeConfig $ appExtra conf of
+                    BSCFile root -> fileStore root
             }
 
     -- Perform database migration using our application's logging settings.
@@ -104,6 +112,15 @@ makeFoundation conf = do
         (Database.Persist.runPool dbconf (runMigration migrateAll) p)
         (messageLoggerSource foundation logger)
 
+    -- Start the cabal file loader
+    void $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do
+        when development $ liftIO $ threadDelay $ 5 * 60 * 1000000
+        eres <- tryAny $ runReaderT loadCabalFiles foundation
+        case eres of
+            Left e -> $logError $ tshow e
+            Right () -> return ()
+        liftIO $ threadDelay $ 30 * 60 * 1000000
+
     return foundation
 
 -- for yesod devel

Data/BlobStore.hs

@@ -0,0 +1,94 @@
+module Data.BlobStore
+    ( BlobStore (..)
+    , ToPath (..)
+    , fileStore
+    , HasBlobStore (..)
+    , storeWrite
+    , storeRead
+    , storeExists
+    ) where
+
+import ClassyPrelude.Yesod
+import qualified Filesystem as F
+import Control.Monad.Reader (MonadReader, ask)
+import Control.Monad.Trans.Resource (release)
+import qualified Aws
+
+data BlobStore key = BlobStore
+    { storeWrite'  :: !(forall m. MonadIO m => key -> Acquire (Sink ByteString m ()))
+    , storeRead'   :: !(forall m. MonadIO m => key -> Acquire (Maybe (Source m ByteString)))
+    , storeExists' :: !(forall m. MonadIO m => key -> m Bool)
+    }
+
+class HasBlobStore a key | a -> key where
+    getBlobStore :: a -> BlobStore key
+instance HasBlobStore (BlobStore key) key where
+    getBlobStore = id
+
+storeWrite :: (MonadResource m, MonadReader env m, HasBlobStore env key)
+           => key
+           -> Consumer ByteString m ()
+storeWrite key = do
+    store <- liftM getBlobStore ask
+    (releaseKey, sink) <- allocateAcquire $ storeWrite' store key
+    toConsumer sink
+    release releaseKey
+
+storeRead :: (MonadResource m, MonadReader env m, HasBlobStore env key)
+          => key
+          -> m (Maybe (Source m ByteString))
+storeRead key = do
+    store <- liftM getBlobStore ask
+    (releaseKey, msrc) <- allocateAcquire $ storeRead' store key
+    case msrc of
+        Nothing -> do
+            release releaseKey
+            return Nothing
+        Just src -> return $ Just $ src >> release releaseKey
+
+storeExists :: (MonadIO m, MonadReader env m, HasBlobStore env key)
+            => key
+            -> m Bool
+storeExists key = do
+    store <- liftM getBlobStore ask
+    storeExists' store key
+
+class ToPath a where
+    toPath :: a -> [Text]
+
+fileStore :: ToPath key
+          => FilePath -- ^ root
+          -> BlobStore key
+fileStore root = BlobStore
+    { storeWrite' = \key -> sinkHandle <$> mkAcquire
+        (do
+            let fp = toFP key
+            F.createTree $ directory fp
+            F.openFile fp F.WriteMode)
+        hClose
+    , storeRead' = \key -> (fmap sourceHandle) <$> mkAcquire
+        ((Just <$> F.openFile (toFP key) F.ReadMode)
+            `catch` \e ->
+                if isDoesNotExistError e
+                    then return Nothing
+                    else throwIO e)
+        (maybe (return ()) hClose)
+    , storeExists' = liftIO . F.isFile . toFP
+    }
+  where
+    toFP key = foldl' (\x y -> x </> fpFromText y) root (toPath key)
+
+{-
+-- | Note: Only use with data which will never be modified!
+cachedS3Store :: (BackupToS3 key, ToPath key)
+              => FilePath -- ^ cache directory
+              -> Aws.Bucket
+              -> Text -- ^ prefix within bucket
+              -> BlobStore key
+cachedS3Store cache bucket prefix = BlobStore
+    { storeWrite' = \key -> 
+    }
+
+class BackupToS3 key where
+    shouldBackup :: key -> Bool
+-}

Data/Hackage.hs

@@ -0,0 +1,103 @@
+module Data.Hackage
+    ( loadCabalFiles
+    , sourceHackageSdist
+    ) where
+
+import ClassyPrelude.Yesod
+import Types
+import Data.BlobStore
+import Data.Conduit.Lazy (MonadActive (..), lazyConsume)
+import Control.Monad.Logger (LoggingT)
+import qualified Codec.Archive.Tar as Tar
+import Control.Monad.Reader (MonadReader, ask)
+import Control.Monad.Trans.Resource (release)
+import qualified Data.Text as T
+import Data.Conduit.Zlib (ungzip)
+
+loadCabalFiles :: ( MonadActive m
+                  , MonadBaseControl IO m
+                  , MonadThrow m
+                  , MonadIO m
+                  , MonadReader env m
+                  , HasHttpManager env
+                  , HasBlobStore env StoreKey
+                  , HasHackageRoot env
+                  , MonadLogger m
+                  )
+               => m ()
+loadCabalFiles = do
+    HackageRoot root <- liftM getHackageRoot ask
+    $logDebug $ "Entering loadCabalFiles, root == " ++ root
+    req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz"
+    withResponse req $ \res -> do
+        $logDebug $ "Got a response, processing"
+        bss <- lazyConsume $ responseBody res $= ungzip
+        loop $ Tar.read $ fromChunks bss
+  where
+    loop (Tar.Next entry entries) = go entry >> loop entries
+    loop Tar.Done = return ()
+    loop (Tar.Fail e) = throwM e
+
+    go entry = do
+        case Tar.entryContent entry of
+            Tar.NormalFile lbs _
+                | Just (name, version) <- parseFilePath (Tar.entryPath entry) -> do
+                    let key = HackageCabal name version
+                    exists <- storeExists key
+                    store <- liftM getBlobStore ask
+                    unless exists $ withAcquire (storeWrite' store key) $ \sink ->
+                        sourceLazy lbs $$ sink
+            _ -> return ()
+
+parseFilePath :: String -> Maybe (PackageName, Version)
+parseFilePath s =
+    case filter (not . null) $ T.split (== '/') $ pack s of
+        (name:version:_) -> Just (PackageName name, Version version)
+        _ -> Nothing
+
+sourceHackageSdist :: ( MonadIO m
+                      , MonadThrow m
+                      , MonadBaseControl IO m
+                      , MonadResource m
+                      , MonadReader env m
+                      , HasHttpManager env
+                      , HasHackageRoot env
+                      , HasBlobStore env StoreKey
+                      )
+                   => PackageName
+                   -> Version
+                   -> m (Maybe (Source m ByteString))
+sourceHackageSdist name version = do
+    let key = HackageSdist name version
+    msrc1 <- storeRead key
+    case msrc1 of
+        Just src -> return $ Just src
+        Nothing -> do
+            HackageRoot root <- liftM getHackageRoot ask
+            let url = concat
+                        [ root
+                        , "/"
+                        , toPathPiece name
+                        , "/"
+                        , toPathPiece version
+                        , "/"
+                        , toPathPiece name
+                        , "-"
+                        , toPathPiece version
+                        , ".tar.gz"
+                        ]
+            req' <- parseUrl $ unpack url
+            let req = req' { checkStatus = \_ _ _ -> Nothing }
+            exists <- withResponse req $ \res ->
+                if responseStatus res == status200
+                    then do
+                        responseBody res $$ storeWrite key
+                        return True
+                    else return False
+            if exists
+                then storeRead key
+                else return Nothing
+
+-- FIXME orphan
+instance MonadActive m => MonadActive (LoggingT m) where
+    monadActive = lift monadActive

Foundation.hs

@@ -17,6 +17,8 @@ import Text.Hamlet (hamletFile)
 import Yesod.Core.Types (Logger)
 import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug)
 import qualified System.Random.MWC as MWC
+import Data.BlobStore
+import Types
 
 -- | The site argument for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
@@ -30,14 +32,21 @@ data App = App
     , persistConfig :: Settings.PersistConf
     , appLogger :: Logger
     , genIO :: !MWC.GenIO
+    , blobStore :: !(BlobStore StoreKey)
     }
 
+instance HasBlobStore App StoreKey where
+    getBlobStore = blobStore
+
 instance HasGenIO App where
     getGenIO = genIO
 
 instance HasHttpManager App where
     getHttpManager = httpManager
 
+instance HasHackageRoot App where
+    getHackageRoot = hackageRoot . appExtra . settings
+
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers

Handler/HackageSdist.hs

@@ -0,0 +1,19 @@
+module Handler.HackageSdist where
+
+import Import
+import Data.Hackage
+
+getHackageSdistR :: PackageName -> Version -> Handler TypedContent
+getHackageSdistR name version = do
+    msrc <- sourceHackageSdist name version
+    case msrc of
+        Nothing -> notFound
+        Just src -> do
+            addHeader "content-disposition" $ concat
+                [ "attachment; filename=\""
+                , toPathPiece name
+                , "-"
+                , toPathPiece version
+                , ".tar.gz"
+                ]
+            respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src

Import.hs

@@ -5,6 +5,7 @@ module Import
 import           ClassyPrelude.Yesod  as Import
 import           Foundation           as Import
 import           Model                as Import
+import           Types                as Import
 import           Settings             as Import
 import           Settings.Development as Import
 import           Settings.StaticFiles as Import

Settings.hs

@@ -14,6 +14,8 @@ import Yesod.Default.Util
 import Data.Yaml
 import Settings.Development
 import Text.Hamlet
+import Data.Aeson (withText)
+import Types
 
 -- | Which Persistent backend this site is using.
 type PersistConf = PostgresConf
@@ -63,7 +65,22 @@ widgetFile = (if development then widgetFileReload
               widgetFileSettings
 
 data Extra = Extra
+    { storeConfig :: !BlobStoreConfig
+    , hackageRoot :: !HackageRoot
+    }
     deriving Show
 
 parseExtra :: DefaultEnv -> Object -> Parser Extra
-parseExtra _ _o = return Extra
+parseExtra _ o = Extra
+    <$> o .: "blob-store"
+    <*> (HackageRoot <$> o .: "hackage-root")
+
+data BlobStoreConfig = BSCFile !FilePath
+    deriving Show
+
+instance FromJSON BlobStoreConfig where
+    parseJSON = withText "BlobStoreConfig" $ \t ->
+        case () of
+            ()
+                | Just root <- stripPrefix "file:" t -> return $ BSCFile $ fpFromText root
+                | otherwise -> fail $ "Invalid BlobStoreConfig: " ++ show t

Types.hs

@@ -0,0 +1,36 @@
+module Types where
+
+import ClassyPrelude.Yesod
+import Data.BlobStore (ToPath (..))
+import Text.Blaze (ToMarkup)
+
+newtype PackageName = PackageName { unPackageName :: Text }
+    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup)
+newtype Version = Version { unVersion :: Text }
+    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup)
+newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text }
+    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup)
+
+data StoreKey = HackageCabal !PackageName !Version
+              | HackageSdist !PackageName !Version
+              | CabalIndex !PackageSetIdent
+              | CustomSdist !PackageSetIdent !PackageName !Version
+
+instance ToPath StoreKey where
+    toPath (HackageCabal name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".cabal"]
+    toPath (HackageSdist name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".tar.gz"]
+    toPath (CabalIndex ident) = ["cabal-index", toPathPiece ident ++ ".tar.gz"]
+    toPath (CustomSdist ident name version) =
+        [ "custom-tarball"
+        , toPathPiece ident
+        , toPathPiece name
+        , toPathPiece version ++ ".tar.gz"
+        ]
+
+newtype HackageRoot = HackageRoot { unHackageRoot :: Text }
+    deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup)
+
+class HasHackageRoot a where
+    getHackageRoot :: a -> HackageRoot
+instance HasHackageRoot HackageRoot where
+    getHackageRoot = id

config/routes

@@ -8,3 +8,4 @@
 /profile ProfileR GET PUT
 /email/#EmailId EmailR DELETE
 /reset-token ResetTokenR POST
+/hackage/#PackageName/#Version HackageSdistR GET

config/settings.yml

@@ -2,9 +2,11 @@ Default: &defaults
   host: "*4" # any IPv4 host
   port: 3000
   approot: "http://localhost:3000"
+  hackage-root: http://hackage.haskell.org/packages/archive
 
 Development:
   <<: *defaults
+  blob-store: file:dev-blob-store
 
 Testing:
   <<: *defaults

stackage-server.cabal

@@ -20,10 +20,14 @@ library
                      Settings.StaticFiles
                      Settings.Development
                      Data.Slug
+                     Data.BlobStore
+                     Data.Hackage
+                     Types
                      Handler.Home
                      Handler.Profile
                      Handler.Email
                      Handler.ResetToken
+                     Handler.HackageSdist
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
@@ -47,6 +51,9 @@ library
                 ViewPatterns
                 TypeSynonymInstances
                 FlexibleInstances
+                RankNTypes
+                FunctionalDependencies
+                PatternGuards
 
     build-depends: base                          >= 4          && < 5
                  , yesod                         >= 1.2.5      && < 1.3
@@ -80,7 +87,11 @@ library
                  , mtl                           >= 2.1        && < 2.2
                  , blaze-markup                  >= 0.6        && < 0.7
                  , ghc-prim
-                 , ghc-prim
+                 , system-fileio
+                 , resourcet
+                 , aws                           >= 0.9        && < 0.10
+                 , conduit-extra
+                 , tar                           >= 0.4        && < 0.5
 
 executable         stackage-server
     if flag(library-only)