Commit 3854a128 authored by davean's avatar davean
Browse files

Now with commandline parsing but a memory explosion.

parent f8598080
......@@ -19,7 +19,7 @@ library
default-language: Haskell2010
hs-source-dirs: src
ghc-options: -Wall -fno-warn-unused-binds -O2
ghc-prof-options: -prof -auto-all -fprof-auto
ghc-prof-options: -auto-all -fprof-auto
exposed-modules:
Distribution.Skete.Haskell.Package
build-depends:
......@@ -54,7 +54,10 @@ executable skete-haskell
default-language: Haskell2010
hs-source-dirs: tools
ghc-options: -Wall -O2 -rtsopts -threaded
ghc-prof-options: -prof -auto-all -fprof-auto
ghc-prof-options: -auto-all -fprof-auto
other-modules:
SketeUpdate
, SketeServer
build-depends:
base
, skete
......@@ -67,4 +70,20 @@ executable skete-haskell
, monad-log
, lens
, exceptions
, conduit
\ No newline at end of file
, conduit
, optparse-applicative
, optparse-text
, optparse-helper
, http-types
, warp
, wai
, wai-extra
, parsec
, web-routes
, web-routes-wai
, zlib
, data-default-class
, deepseq
, filepath
, tar
\ No newline at end of file
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, KindSignatures, TemplateHaskell #-}
module Distribution.Skete.Haskell.Package (
createIndexTar
, UpdateConfig(..), HasUpdateConfig(..)
......@@ -67,11 +67,11 @@ createIndexTar entries = Tar.write <$> entries'
data UpdateConfig =
UpdateConfig {
_hackageSchemeHost :: String
_hackageSchemeHost :: Text
, _targetPackageSet :: PackageSet
, _tarballCacheDir :: FilePath
, _tarballCacheDir :: Maybe FilePath
}
deriving (Show, Eq, Ord)
deriving (Read, Show, Eq, Ord)
makeClassy ''UpdateConfig
......@@ -153,7 +153,7 @@ elideSeen =
flip CL.concatMapAccumM mempty $ skipEvents
where
skipEvents :: PackageEvent -> Seq PackageEvent
-> (t m) (Seq PackageEvent, [PackageEvent])
-> t m (Seq PackageEvent, [PackageEvent])
skipEvents (pe@(PackageRevision _ pv cblFl)) delayedEvents = do
ps <- view targetPackageSet
mcabal <- lift $ labelDataLookup ps pv "cabal"
......@@ -200,7 +200,7 @@ getCabalRevision = maybe (Just 0) readMay . List.lookup "x-revision" . customFie
applyPackageEvent :: ( MonadTrans t, MonadLog env (t m), MonadCatch (t m)
, SketeStorage d m r
, HasUpdateConfig c, MonadReader c (t m))
=> PackageEvent -> (t m) ()
=> PackageEvent -> t m ()
applyPackageEvent (PackageRevision occured pv cbl) = do
ps <- view targetPackageSet
Log.info . mconcat $ ["Inserting new package-version ", tshow pv]
......@@ -249,13 +249,13 @@ applyPackageEvent (PackagePreferred occured pn pref) = do
When the function we've been passed returns successfully, we assume that all the
remaining index has been processed, and update the stored offset.
-}
getIndexRemaining :: forall t m env c b
. ( MonadTrans t, MonadIO (t m), MonadCatch (t m), MonadLog env (t m)
getIndexRemaining :: forall (t :: (* -> *) -> * -> *) m env c a
. ( MonadIO (t m), MonadCatch (t m), MonadLog env (t m)
, HasUpdateConfig c, MonadReader c (t m))
=> (Tar.Entries Tar.FormatError -> (t m) b) -> (t m) b
=> (Tar.Entries Tar.FormatError -> t m a) -> t m a
getIndexRemaining act = do
indexUrl <- (++"/01-index.tar") <$> view hackageSchemeHost
Log.info . mconcat $ ["Following updates from ", T.pack indexUrl]
indexUrl <- (`T.append` "/01-index.tar") <$> view hackageSchemeHost
Log.info . mconcat $ ["Following updates from ", indexUrl]
mOldOff <- followFromExisting
Log.info $ maybe "Starting from the start of the index"
(\i -> "Trying to read the index from " `T.append` (T.pack . show $ i))
......@@ -302,6 +302,9 @@ getIndexRemaining act = do
getPackageTar :: (MonadIO m, MonadCatch m, MonadLog env m, HasUpdateConfig c, MonadReader c m)
=> PackageVersion -> m BSL.ByteString
getPackageTar pkg = do
cacheDir <- view tarballCacheDir
cachingGet (cacheDir </> show pkg) . T.intercalate "/" $
["https://hackage.haskell.org/package", tshow pkg, tshow pkg <> ".tar.gz"]
mCacheDir <- view tarballCacheDir
let uri = T.intercalate "/" $ [ "https://hackage.haskell.org/package"
, tshow pkg, tshow pkg <> ".tar.gz"]
case mCacheDir of
Just cacheDir -> cachingGet (cacheDir </> show pkg) uri
Nothing -> cachelessGet uri
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving, FunctionalDependencies #-}
module Main where
import qualified Control.Monad.Catch as E
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Conduit (($=), ($$))
import qualified Data.Conduit.List as CL
import Control.Monad.Reader
import Control.Monad.Log
import qualified Control.Monad.Log as Log
import Control.Lens
import qualified Network.Wai.Handler.Warp as Warp
import Data.Semigroup ((<>))
import Options.Applicative
import Options.Applicative.Text
import Options.Applicative.Helper
import qualified Distribution.Skete.Storage.Interface as Storage
import qualified Distribution.Skete.Storage.GitFat as GitFat
import Distribution.Skete.Haskell.Package
data SketeToolConfig =
STK {
_loggerData :: Logger ()
, _stkUpdateConfig :: UpdateConfig
import SketeUpdate
--import SketeServer
data CommandOptions =
COImport {
_coUpdateConf :: UpdateConfig
, _coRepo :: T.Text
}
| COServe {
_coPort :: Warp.Port
, _coRepo :: T.Text
}
-- | CODocs {
-- _coPackageVersion :: Storage.PackageVersion
-- , _coPackageSet :: Storage.PackageSet
-- , _coRepo :: T.Text
-- }
deriving (Read, Show, Eq, Ord)
makeClassy ''CommandOptions
commandParser :: Parser CommandOptions
commandParser =
subconcat [
parseImport
, parseServe
-- , parseDocs
]
where
parsePackageSet =
textOption $
long "set"
<> metavar "PACKAGESET"
<> showDefault
<> help "The PackageSet to import the new PackageVersions into."
<> value "all"
parseRepo =
textOption $
long "repo"
<> metavar "GITDIR"
<> help "The location of the skete store."
<> value "./.git"
parseImport =
command "import" $
infoHelper `flip` (fpDesc "import") $
COImport <$> (UpdateConfig <$>
textOption (
long "upstream"
<> metavar "HACKAGE"
<> showDefault
<> help "A schema+host for a Hackage-like service to import PackageVersions from."
<> value "https://hackage.haskell.org" )
<*> parsePackageSet
<*> ((Just <$> strOption (
long "cache"
<> metavar "CACHEDIR"
<> help "A location to find predownloaded tarballs and save tarballs as they're downloaded." ))
<|> (pure Nothing)))
<*> parseRepo
parseServe =
command "serve" $
infoHelper `flip` (fpDesc "import") $
COServe <$>
option auto (
long "port"
<> metavar "PORT"
<> showDefault
<> help "Which port to provide a subset of the Hackage API on."
<> value 8081 )
<*> parseRepo
-- parseDocs = Prelude.error "doc parser not completed"
data CommandConfig =
CCImport {
_ccUpConf :: UpdateConfig
}
-- | CCServe {
-- _ccPort :: Warp.Port
-- }
deriving (Show, Eq, Ord)
makeClassy ''SketeToolConfig
makeClassy ''CommandConfig
instance HasUpdateConfig SketeToolConfig where
updateConfig = stkUpdateConfig
instance HasUpdateConfig CommandConfig where
updateConfig = ccUpConf
newtype SketeToolT m a =
SketeToolT { runSketeToolT :: ReaderT SketeToolConfig m a }
data WrappedConfig c =
WrappedConfig {
_wcLoggerConf :: Log.Logger ()
, _wcComConf :: c
}
makeClassy ''WrappedConfig
instance HasUpdateConfig (WrappedConfig UpdateConfig) where
updateConfig = wcComConf
newtype SketeToolT c m a =
SketeToolT { runSketeToolT :: ReaderT (WrappedConfig c) m a }
deriving ( Functor, Applicative, Monad, MonadIO, E.MonadThrow, E.MonadCatch
, MonadTrans, MonadReader SketeToolConfig)
, MonadTrans, MonadReader (WrappedConfig c) )
instance MonadIO m => MonadLog () (SketeToolT m) where
askLogger = view loggerData
localLogger f m = local (over loggerData f) m
instance MonadIO m => Log.MonadLog () (SketeToolT c m) where
askLogger = view wcLoggerConf
localLogger f m = local (over wcLoggerConf f) m
main :: IO ()
main = do
logConf <- makeDefaultLogger simpleTimeFormat (LogStderr 0) (Level 2) ()
(Storage.storage (GitFat.GFC . TE.encodeUtf8 $ ".git")::GitFat.GitFat p a -> IO a) $ do
((flip runReaderT) (STK logConf config) . runSketeToolT) $ do
getIndexRemaining $ \idxEnts ->
streamIndex idxEnts $= elideSeen $$ CL.mapM_ applyPackageEvent
where
config = UpdateConfig "https://hackage.haskell.org" "all" "../hackage"
logConf <- Log.makeDefaultLogger
Log.simpleTimeFormat (Log.LogStderr 0) (Log.Level 2) ()
--Log.runLogTSafe logConf . Log.debug . mconcat $ ["Logger created"]
cmd <- helperExecParser commandParser
(fpDesc "skete-haskell, the skete Haskell package manager.")
(Storage.storage (GitFat.GFC . TE.encodeUtf8 $ (cmd ^. coRepo))::GitFat.GitFat p a -> IO a) $ do
case cmd of
COImport {_coUpdateConf=upConf} ->
(runReaderT `flip` (WrappedConfig logConf upConf)) . runSketeToolT $ do
fullUpdate
_ -> liftIO . print $ cmd
{-
......
{-# LANGUAGE OverloadedStrings #-}
module Main where
module SketeServer where
import Data.Maybe
import Control.Monad
......@@ -61,8 +61,8 @@ instance PathInfo SiteMap where
toPathSegments = genURL
fromPathSegments = parseURL
main :: IO ()
main = do
server :: IO ()
server = do
let ss = GitFat.GFC. TE.encodeUtf8 $ ".git"
logger <- WAI.mkRequestLogger def
Warp.run 8080 $ logger (handleWai (TE.encodeUtf8 "") $
......@@ -78,7 +78,7 @@ serveTar ss pid _ respond = (Storage.storage ss::GitFat.GitFat p a -> IO a) $ do
Nothing -> do
liftIO . respond . WAI.responseLBS HTTP.status404 [] $ "I will not give you what you want"
Just pr -> do
dt <- Storage.packageFiles pr
dt <- Storage.versionFiles pr
liftIO . respond . WAI.responseLBS HTTP.status200 [] .
GZ.compressWith (GZ.defaultCompressParams { GZ.compressLevel = GZ.bestSpeed }) .
implodeTar $ dt
......
{-# LANGUAGE ScopedTypeVariables #-}
module SketeUpdate where
import qualified Control.Monad.Catch as E
import Data.Conduit (($=), ($$))
import qualified Data.Conduit.List as CL
import Control.Monad.Reader
import Control.Monad.Log
import qualified Codec.Archive.Tar as Tar
import qualified Distribution.Skete.Storage.Interface as Storage
import Distribution.Skete.Haskell.Package
fullUpdate :: forall t m env c d r
. ( MonadTrans t, MonadIO (t m), E.MonadCatch (t m)
, MonadLog env (t m), HasUpdateConfig c, MonadReader c (t m)
, Storage.SketeStorage d m r)
=> t m ()
fullUpdate =
getIndexRemaining go
where
go :: Tar.Entries Tar.FormatError -> t m ()
go idxEnts = streamIndex idxEnts $= elideSeen $$ CL.mapM_ applyPackageEvent
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment