Commit 5c7777ed authored by Emily Pillmore's avatar Emily Pillmore 🍆
Browse files

WIP from yesterday

parent 45c860de
......@@ -65,8 +65,11 @@ library
Control.Monad.Skete
Control.Monad.Skete.Class
Distribution.Skete.Haskell.Config
Distribution.Skete.Haskell.Logger
Distribution.Skete.Haskell.Package
Distribution.Skete.Haskell.Types.Config
Distribution.Skete.Haskell.Types.Event
Distribution.Skete.Haskell.Types.Exceptions
--Distribution.Skete.Haskell.Server.API
......
......@@ -20,11 +20,10 @@ import Control.Lens
import Control.Monad.Catch
import Control.Monad.Morph
import Control.Monad.Reader
import Control.Monad.State.Strict
import Distribution.Skete.Haskell.Config
import Distribution.Skete.Storage.GitFat
import Distribution.Skete.Storage.Interface
import Distribution.Skete.Haskell.Types.Config
import GHC.Stack
......@@ -38,12 +37,11 @@ import GHC.Stack
--
newtype SketeServiceT conf msg m a = SketeServiceT
{ _runSketeServiceT
:: ReaderT (WrappedConfig conf) (StateT (LogAction (SketeServiceT conf msg m) msg) m) a
:: ReaderT (ServiceConfig conf msg (SketeServiceT conf msg m)) m a
} deriving
( Functor, Applicative, Monad
, MonadIO, MonadThrow, MonadCatch, MonadMask
, MonadReader (WrappedConfig conf)
, MonadState (LogAction (SketeServiceT conf msg m) msg)
, MonadReader (ServiceConfig conf msg (SketeServiceT conf msg m))
)
type SketeService conf msg a = SketeServiceT conf msg IO a
......@@ -55,7 +53,7 @@ instance MFunctor (SketeServiceT conf msg) where
instance MonadTrans (SketeServiceT conf msg) where
lift = lift
-- | Run a skete service context
-- | Run a skete service context.
--
-- Runs a skete logging monad for a given log action.
--
......@@ -63,18 +61,17 @@ runSketeServiceT
:: HasCallStack
=> MonadThrow m
=> MonadIO m
=> WrappedConfig conf
-> LogAction (SketeServiceT conf msg (GitFat p m)) msg
=> ServiceConfig conf msg (SketeServiceT conf msg (GitFat p m))
-> SketeServiceT conf msg (GitFat p m) a
-> m a
runSketeServiceT wc l act = storage (wc ^. wrappedGitConfig)
$ flip evalStateT l
$ runReaderT (_runSketeServiceT act) wc
runSketeServiceT conf act
= storage (conf ^. serviceConfig . wrappedGitConfig)
$ runReaderT (_runSketeServiceT act) conf
{-# specialize
runSketeServiceT
:: WrappedConfig conf
-> LogAction (SketeServiceT conf msg (GitFat p IO)) msg
-> SketeServiceT conf msg (GitFat p IO) a
:: ServiceConfig conf Message (SketeServiceT conf Message (GitFat p IO))
-> SketeServiceT conf Message (GitFat p IO) a
-> IO a
#-}
......@@ -90,10 +87,10 @@ runServiceStorage
=> SketeServiceT conf msg (GitFat p m) a
-> SketeServiceT conf msg m a
runServiceStorage act = do
c <- view wrappedGitConfig
c <- view $ serviceConfig . wrappedGitConfig
hoist (storage c) act
{-# specialize
runServiceStorage
:: SketeServiceT conf msg (GitFat p IO) a
-> SketeServiceT conf msg IO a
:: SketeServiceT conf Message (GitFat p IO) a
-> SketeServiceT conf Message IO a
#-}
......@@ -8,19 +8,16 @@ module Control.Monad.Skete.Class
import Colog.Core
import Control.Monad.Reader
import Control.Lens
import Control.Monad.Skete
import Control.Monad.State.Strict
import Distribution.Skete.Haskell.Config
import Distribution.Skete.Haskell.Types.Config
-- | The typelcass associated with the Skete service.
--
-- Every skete service must know how to access its logger,
-- its com conf, and its repo data.
--
-- /Note/: logger actions exist in
class MonadSkete conf msg m | m -> msg, m -> conf where
sketeConf :: m conf
sketeLogger :: m (LogAction m msg)
......@@ -28,6 +25,6 @@ class MonadSkete conf msg m | m -> msg, m -> conf where
instance Monad m => MonadSkete conf msg (SketeServiceT conf msg m) where
sketeConf = asks _wcComConf
sketeLogger = get
sketeRepo = asks _wcRepo
sketeConf = view $ serviceConfig . wcComConf
sketeLogger = view serviceLogger
sketeRepo = view $ serviceConfig . wcRepo
{-# language BangPatterns #-}
{-# language ConstraintKinds #-}
{-# language FlexibleInstances #-}
{-# language FunctionalDependencies #-}
{-# language MultiParamTypeClasses #-}
{-# language TypeSynonymInstances #-}
module Distribution.Skete.Haskell.Logger
( log
, logInfo
, logWarn
, logDebug
, logError
) where
import Colog.Core.Action
import Colog.Core.Severity
import Colog.Message (Msg(..), Message)
import Control.Lens
import Control.Monad.Skete.Class
import Data.Functor (void)
import Data.Text
import GHC.Stack
import Prelude hiding (log)
-- ---------------------------------------------------------------------- --
-- Skete messages
class HasSeverity msg where
severity :: Lens' msg Severity
severity = lens getSeverity setSeverity
getSeverity :: msg -> Severity
getSeverity = view severity
setSeverity :: msg -> Severity -> msg
setSeverity = flip (set severity)
{-# minimal severity | getSeverity, setSeverity #-}
instance HasSeverity Message where
severity = lens msgSeverity (\t b -> t { msgSeverity = b })
class HasTrace msg where
callstack :: Lens' msg CallStack
callstack = lens getCallstack setCallstack
getCallstack :: msg -> CallStack
getCallstack = view callstack
setCallstack :: msg -> CallStack -> msg
setCallstack = flip (set callstack)
{-# minimal callstack | getCallstack, setCallstack #-}
instance HasTrace Message where
callstack = lens msgStack (\t b -> t { msgStack = b })
class HasMsg msg a | msg -> a where
message :: Lens' msg a
message = lens getMsg setMsg
getMsg :: msg -> a
getMsg = view message
setMsg :: msg -> a -> msg
setMsg = flip (set message)
{-# minimal message | getMsg, setMsg #-}
instance HasMsg Message Text where
message = lens msgText (\t b -> t { msgText = b })
type WithLog conf msg m
= (HasCallStack, Monad m, HasTrace msg, HasSeverity msg, MonadSkete conf msg m)
-- ---------------------------------------------------------------------- --
-- Logging utils
log :: WithLog conf msg m => Severity -> msg -> m ()
log sev msg = withFrozenCallStack $ do
let enrichedMsg = msg
& callstack .~ callStack
& severity .~ sev
LogAction logger <- sketeLogger
void $! logger enrichedMsg
{-# inline log #-}
logInfo :: WithLog conf msg m => msg -> m ()
logInfo = log Info
{-# inline logInfo #-}
logWarn :: WithLog conf msg m => msg -> m ()
logWarn = log Warning
{-# inline logWarn #-}
logDebug :: WithLog conf msg m => msg -> m ()
logDebug = log Debug
{-# inline logDebug #-}
logError :: WithLog conf msg m => msg -> m ()
logError = log Error
{-# inline logError #-}
......@@ -26,6 +26,7 @@ import Control.Monad
import Control.Monad.Catch (MonadThrow, MonadCatch)
import qualified Control.Monad.Catch as E
import Control.Monad.Skete
import Control.Monad.Skete.Class
import Control.Monad.Reader.Class
import Control.Monad.Trans
......@@ -49,6 +50,9 @@ import Data.Time.Clock.POSIX
import Distribution.PackageDescription (GenericPackageDescription(packageDescription), PackageDescription(customFieldsPD))
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult, ParseResult)
import Distribution.Skete.DownloadUtils
import qualified Distribution.Skete.Haskell.Logger as Log
import Distribution.Skete.Haskell.Types.Config
import Distribution.Skete.Haskell.Types.Event
import Distribution.Skete.Storage.Interface
import Distribution.Skete.TarUtils
......@@ -58,14 +62,10 @@ import qualified System.AtomicWrite.Writer.Text as TIO
import System.Directory (createDirectoryIfMissing)
import System.FilePath
import qualified System.IO.Error as IOE
import Distribution.Skete.Haskell.Config
data DatabaseCorruption =
DatabaseCorruption
deriving (Show)
instance EB.Exception DatabaseCorruption
tshow :: Show s => s -> Text
tshow = T.pack . show
......@@ -80,46 +80,21 @@ createIndexTar =
Right tarPath -> yield $ MTar.fileEntry tarPath file) ~>
MTar.write
data UpdateConfig =
UpdateConfig {
_hackageSchemeHost :: Text
, _targetPackageSet :: PackageSet
, _tarballCacheDir :: Maybe FilePath
}
deriving (Read, Show, Eq, Ord)
makeClassy ''UpdateConfig
instance HasUpdateConfig (WrappedConfig UpdateConfig) where
updateConfig = wcComConf
data PackageEvent =
PackageRevision {
peWhen :: UTCTime
, pePackageVersion :: PackageVersion
, peCabal :: BS.ByteString
}
| PackagePreferred {
peWhen :: UTCTime
, pePackage :: Package
, pePreferred :: BS.ByteString
}
deriving (Ord, Eq, Show, Read)
{- | Walk the entries in the (read) tar passed in, and emit package events based on
the contents that represent them. This is done in tar order, which happens to,
importantly, be temporal order.
-}
streamIndex :: forall env m. (MonadThrow m, MonadLog env m)
streamIndex :: forall conf msg m. (MonadThrow m, MonadSkete conf msg m)
=> Tar.Entries Tar.FormatError -> SourceT m PackageEvent
streamIndex = construct . streamIndex'
where
streamIndex' :: Tar.Entries Tar.FormatError -> PlanT k PackageEvent m ()
streamIndex' Tar.Done = do
lift . Log.info $ "Current 01-index.tar completed"
lift . Log.logInfo $ "Current 01-index.tar completed"
stop
streamIndex' (Tar.Fail e) = do
lift . Log.error . mconcat $ ["Tar failed with: ", tshow e]
lift . Log.logError . mconcat $ ["Tar failed with: ", tshow e]
lift . E.throwM $ e
streamIndex' (Tar.Next ent t) = do
case Tar.entryContent ent of
......@@ -127,11 +102,11 @@ streamIndex = construct . streamIndex'
lift . Log.debug . mconcat $ ["Processing cabal entry: ", tshow ent]
case tarPath2PackageVersion . Tar.entryPath $ ent of
Nothing -> do
lift . Log.error . mconcat $ [ "Failed to parse PackageVersion of '"
lift . Log.logError . mconcat $ [ "Failed to parse PackageVersion of '"
, T.pack . Tar.entryPath $ ent, "'!"]
lift . E.throwM . EB.ErrorCall $ "PackageVersion parse failed!"
Just pv -> do
lift . Log.info . mconcat $ ["Got cabal entry for: ", tshow pv]
lift . Log.logInfo . mconcat $ ["Got cabal entry for: ", tshow pv]
yield $
PackageRevision (posixSecondsToUTCTime . realToFrac . Tar.entryTime $ ent)
pv .
......@@ -140,11 +115,11 @@ streamIndex = construct . streamIndex'
lift . Log.debug . mconcat $ ["Processing preferred-versions entry: ", tshow ent]
case fmap dropTrailingPathSeparator . splitPath . Tar.entryPath $ ent of
[pn, "preferred-versions"] -> do
lift . Log.info . mconcat $ ["Got preferred-versions entry for: ", T.pack pn]
lift . Log.logInfo . mconcat $ ["Got preferred-versions entry for: ", T.pack pn]
yield . PackagePreferred (posixSecondsToUTCTime . realToFrac . Tar.entryTime $ ent)
(T.pack pn) . BSL.toStrict $ prefVersion
_ -> do
lift . Log.error . mconcat $ [ "Failed to parse Package of '"
lift . Log.logError . mconcat $ [ "Failed to parse Package of '"
, T.pack . Tar.entryPath $ ent, "'!" ]
lift . E.throwM . EB.ErrorCall $ "Package parse failed!"
Tar.NormalFile _ _ | (takeFileName . Tar.entryPath $ ent) == "package.json" -> do
......@@ -206,7 +181,7 @@ elideSeen =
case ( runParseResult . parseCabalByteString <$> mcabal
, runParseResult . parseCabalByteString $ cblFl) of
(Just (_, Left (_, perr)), _) -> do
Log.error . mconcat $ ["Failed to parse old cabal file for ", tshow pv, ": ", tshow perr]
Log.logError . mconcat $ ["Failed to parse old cabal file for ", tshow pv, ": ", tshow perr]
E.throwM DatabaseCorruption
(_, (_, Left (_, perr))) -> do
Log.warning . mconcat $ ["Failed to parse new cabal file for ", tshow pv, ": ", tshow perr]
......@@ -217,7 +192,7 @@ elideSeen =
(Just (_, Right oldCabal), (_, Right newCabal)) -> do
case (getCabalRevision oldCabal, getCabalRevision newCabal) of
(Nothing, _) -> do
Log.error . mconcat $ ["Could not parse x-revision field of old cabal file for ", tshow pv]
Log.logError . mconcat $ ["Could not parse x-revision field of old cabal file for ", tshow pv]
E.throwM . EB.AssertionFailed $ "x-revision field of old "<>show pv<>" cabal not parsable"
(_, Nothing) -> do
Log.warning . mconcat $ ["Could not parse x-revision field of new cabal file for ", tshow pv]
......@@ -248,7 +223,7 @@ applyPackageEvent :: ( MonadTrans t, MonadLog env (t m), MonadCatch (t m)
=> PackageEvent -> t m ()
applyPackageEvent (PackageRevision occured pv cbl) = do
ps <- view targetPackageSet
Log.info . mconcat $ ["Inserting new package-version ", tshow pv]
Log.logInfo . mconcat $ ["Inserting new package-version ", tshow pv]
mr <- lift $ lookup pv
case mr of
Nothing -> do
......@@ -264,10 +239,10 @@ applyPackageEvent (PackageRevision occured pv cbl) = do
Just r -> do
Log.debug . mconcat $ ["Updating cabal for ", tshow pv]
lift $ label' r (Map.singleton "cabal" cbl) ps occured
Log.info . mconcat $ ["Updated ", tshow pv]
Log.logInfo . mconcat $ ["Updated ", tshow pv]
applyPackageEvent (PackagePreferred occured pn pref) = do
ps <- view targetPackageSet
Log.info . mconcat $ ["Inserting new preferred-versions for ", pn]
Log.logInfo . mconcat $ ["Inserting new preferred-versions for ", pn]
mOldPreferred <- lift $ packageDataLookup ps pn "preferred-versions"
case mOldPreferred of
Nothing -> do
......@@ -278,7 +253,7 @@ applyPackageEvent (PackagePreferred occured pn pref) = do
Just _ -> do
Log.debug . mconcat $ ["Setting new preferred-versions for ", pn]
lift $ labelPackage' ps pn (Map.singleton "preferred-versions" pref) occured
Log.info . mconcat $ ["Set preferreds for ", pn]
Log.logInfo . mconcat $ ["Set preferreds for ", pn]
{- | Figure out where we should continue reading the hackage 01-index.tar
There are two ways we do this:
......@@ -298,9 +273,9 @@ getIndexRemaining :: forall (t :: (* -> *) -> * -> *) m env c a
=> (Tar.Entries Tar.FormatError -> t m a) -> t m a
getIndexRemaining act = do
indexUrl <- (`T.append` "/01-index.tar") <$> view hackageSchemeHost
Log.info . mconcat $ ["Following updates from ", indexUrl]
Log.logInfo . mconcat $ ["Following updates from ", indexUrl]
mOldOff <- followFromExisting
Log.info $ maybe "Starting from the start of the index"
Log.logInfo $ maybe "Starting from the start of the index"
(\i -> "Trying to read the index from " `T.append` (T.pack . show $ i))
mOldOff
{-
......@@ -310,11 +285,11 @@ getIndexRemaining act = do
-- We asked for a range, and actually got a partial response back,
-- so we're safe to start from here.
Just offset | r ^. responseStatus.statusCode == 206 -> do
Log.info "Successful restart from mid-index"
Log.logInfo "Successful restart from mid-index"
return $ offset+BSL.length tarTail
-- If either of those conditions don't hold, we look at every event again.
_ -> do
Log.info "Replaying full index"
Log.logInfo "Replaying full index"
return $ BSL.length tarTail
liftIO $ BSL.writeFile "01-index.tar" tarTail -}
tarTail <- liftIO $ BSL.readFile "01-index.tar"
......
......@@ -2,31 +2,62 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
module Distribution.Skete.Haskell.Config
module Distribution.Skete.Haskell.Types.Config
( Repo(..)
, repoConfig
, WrappedConfig(..)
, wcRepo
, wcComConf
, wrappedGitConfig
, UpdateConfig(..)
, HasUpdateConfig(..)
, ServiceConfig(..)
, serviceConfig
, serviceLogger
) where
import Colog hiding (Lens')
import Control.Lens
import qualified Distribution.Skete.Storage.GitFat as GitFat
import Data.Text
import Distribution.Skete.Storage.GitFat
import Distribution.Skete.Storage.Interface (PackageSet)
newtype Repo = Repo { _repoConfig :: GitFat.GitFatConfig }
newtype Repo = Repo { _repoConfig :: GitFatConfig }
deriving (Read, Show, Eq, Ord)
makeLenses ''Repo
makeWrapped ''Repo
data UpdateConfig =
UpdateConfig {
_hackageSchemeHost :: Text
, _targetPackageSet :: PackageSet
, _tarballCacheDir :: Maybe FilePath
}
deriving (Read, Show, Eq, Ord)
makeClassy ''UpdateConfig
data WrappedConfig c = WrappedConfig
{ _wcRepo :: Repo
, _wcComConf :: c
}
makeLenses ''WrappedConfig
wrappedGitConfig :: Lens' (WrappedConfig c) GitFat.GitFatConfig
instance HasUpdateConfig (WrappedConfig UpdateConfig) where
updateConfig = wcComConf
wrappedGitConfig :: Lens' (WrappedConfig c) GitFatConfig
wrappedGitConfig = wcRepo . repoConfig
{-# inline wrappedGitConfig #-}
data ServiceConfig conf msg m = ServiceConfig
{ _serviceConfig :: WrappedConfig conf
, _serviceLogger :: LogAction m msg
}
makeLenses ''ServiceConfig
{-# language TemplateHaskell #-}
module Distribution.Skete.Haskell.Types.Event
( PackageEvent(..)
, _Revision
, _Preferred
, PackageRevision(..)
, revWhen
, revPackageVersion
, revCabal
, PackagePreferred(..)
, prefWhen
, prefPackage
, prefPreferred
) where
import Control.Lens
import qualified Data.ByteString as BS
import Data.Time.Clock (UTCTime)
import Distribution.Skete.Storage.Interface
data PackageRevision = PackageRevision
{ _revWhen :: UTCTime
, _revPackageVersion :: PackageVersion
, _revCabal :: BS.ByteString
} deriving (Eq, Ord, Show, Read)
makeLenses ''PackageRevision
data PackagePreferred = PackagePreferred
{ _prefWhen :: UTCTime
, _prefPackage :: Package
, _prefPreferred :: BS.ByteString
} deriving (Eq, Ord, Show, Read)
makeLenses ''PackagePreferred
data PackageEvent
= Revision PackageRevision
| Preferred PackagePreferred
deriving (Ord, Eq, Show, Read)
makePrisms ''PackageEvent
module Distribution.Skete.Haskell.Types.Exceptions
( DatabaseCorruption(..)
) where
import Control.Exception
data DatabaseCorruption = DatabaseCorruption
deriving (Show)
instance Exception DatabaseCorruption
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