module Control.Biegunka.Groups
( Partitioned, Groups, GroupRecord(..), SourceRecord(..), FileRecord(..)
, these, those, groups
, open, commit, close, fromScript
, diff, files, sources
, who
) where
import Control.Applicative
import Control.Monad ((<=<))
import Data.Function (on)
import Data.Monoid (Monoid(..))
import Control.Lens hiding ((.=), (<.>))
import Control.Monad.Free (Free(..), iterM)
import Control.Monad.State (State, execState)
import Data.Acid
import Data.Acid.Local
import Data.Aeson
import Data.Foldable (any, elem, for_)
import Data.List ((\\))
import Data.Map (Map)
import qualified Data.Map as M
import Data.SafeCopy (deriveSafeCopy, base, extension, Migrate(..))
import Data.Set (Set)
import qualified Data.Set as S
import Data.Typeable (Typeable)
import Prelude hiding (any, elem)
import System.FilePath.Lens hiding (extension)
import Control.Biegunka.Settings
(Settings, Targets(..), appData, targets)
import Control.Biegunka.Language (Scope(..), Term(..), Source(..), Action(..))
import Control.Biegunka.Script (Annotate(..), UserW(..), User(..))
who :: Maybe (Either String Int) -> String
who = either id show . maybe (Left "(unknown)") id
data SourceRecord_v0 = SR_v0 String FilePath FilePath
data SourceRecord = SR
{ sourceType :: String
, fromLocation :: FilePath
, sourcePath :: FilePath
, sourceOwner :: Maybe (Either String Int)
} deriving (Show, Read)
instance Eq SourceRecord where
(==) = (==) `on` sourcePath
instance Ord SourceRecord where
(<=) = (<=) `on` sourcePath
instance ToJSON SourceRecord where
toJSON SR { sourceType, fromLocation, sourcePath, sourceOwner } = object
[ "type" .= sourceType
, "from" .= fromLocation
, "path" .= sourcePath
, "user" .= who sourceOwner
]
deriveSafeCopy 0 'base ''SourceRecord_v0
instance Migrate SourceRecord where
type MigrateFrom SourceRecord = SourceRecord_v0
migrate (SR_v0 t s p) = SR t s p Nothing
deriveSafeCopy 1 'extension ''SourceRecord
data FileRecord_v0 = FR_v0 String FilePath FilePath
deriving (Show, Read)
data FileRecord = FR
{ fileType :: String
, fromSource :: FilePath
, filePath :: FilePath
, fileOwner :: Maybe (Either String Int)
} deriving (Show)
instance Eq FileRecord where
(==) = (==) `on` filePath
instance Ord FileRecord where
(<=) = (<=) `on` filePath
instance ToJSON FileRecord where
toJSON FR { fileType, fromSource, filePath, fileOwner } = object
[ "type" .= fileType
, "from" .= fromSource
, "path" .= filePath
, "user" .= who fileOwner
]
deriveSafeCopy 0 'base ''FileRecord_v0
instance Migrate FileRecord where
type MigrateFrom FileRecord = FileRecord_v0
migrate (FR_v0 t s p) = FR t s p Nothing
deriveSafeCopy 1 'extension ''FileRecord
newtype GroupRecord = GR
{ unGR :: Map SourceRecord (Set FileRecord)
} deriving (Show, Eq, Typeable)
instance Monoid GroupRecord where
mempty = GR mempty
GR a `mappend` GR b = GR (a `mappend` b)
type instance Index GroupRecord = SourceRecord
type instance IxValue GroupRecord = Set FileRecord
instance Applicative f => Ixed f GroupRecord where
ix k f (GR x) = GR <$> ix k f x
instance ToJSON GroupRecord where
toJSON (GR t) = object [ "sources" .= map repo (M.toList t)]
where
repo (k, v) = object ["info" .= k, "files" .= map toJSON (S.toList v)]
deriveSafeCopy 0 'base ''GroupRecord
newtype Groups = Groups { _groups :: Map String GroupRecord }
deriving (Show, Typeable)
instance ToJSON Groups where
toJSON (Groups gs) = object [ "groups" .= toJSON gs ]
instance Monoid Groups where
mempty = Groups mempty
Groups xs `mappend` Groups ys = Groups (xs `mappend` ys)
makeLensesWith (defaultRules & generateSignatures .~ False) ''Groups
groups :: Lens' Groups (Map String GroupRecord)
deriveSafeCopy 0 'base ''Groups
getMapping :: Query Groups (Map String GroupRecord)
getMapping = view groups
putMapping :: Map String GroupRecord -> Update Groups ()
putMapping = assign groups
makeAcidic ''Groups ['getMapping, 'putMapping]
data Partitioned a = Partitioned
{ _acidic :: AcidState a
, _these :: a
, _those :: a
}
makeLensesWith (defaultRules & generateSignatures .~ False) ''Partitioned
acidic :: Lens' (Partitioned a) (AcidState a)
these :: Lens' (Partitioned a) a
those :: Lens' (Partitioned a) a
open :: Settings () -> IO (Partitioned Groups)
open settings = do
let (path, _) = settings & appData <</>~ "groups"
acid <- openLocalStateFrom path mempty
gs <- query acid GetMapping
let (xs, ys) = mentioned (partition (settings^.targets)) gs
return (Partitioned { _acidic = acid, _these = xs, _those = ys })
where
partition All = \_ _ -> True
partition (Subset s) = \k _ -> k `elem` s
partition (Children s) = \k _ -> any (`isChildOf` k) s
where
isChildOf x y = x `elem` directories y
directories = toListOf (takingWhile (/= ".") (iterated (view directory)))
mentioned p gs = let (xs, ys) = M.partitionWithKey p gs in (Groups xs, Groups ys)
commit :: Partitioned Groups -> IO ()
commit db = update (db^.acidic) (PutMapping (M.union (db^.those.groups) (db^.these.groups)))
close :: Partitioned Groups -> IO ()
close = createCheckpointAndClose . view acidic
diff :: Eq b => (a -> [b]) -> a -> a -> [b]
diff f = (\\) `on` f
files :: Groups -> [FilePath]
files = map filePath . S.elems <=< M.elems . unGR <=< M.elems . view groups
sources :: Groups -> [FilePath]
sources = map sourcePath . M.keys . unGR <=< M.elems . view groups
fromScript :: Free (Term Annotate Sources) a -> Groups
fromScript script = execState (iterM construct script) (Groups mempty)
where
construct :: Term Annotate Sources (State Groups a) -> State Groups a
construct term = case term of
TS (AS { asProfile, asUser }) (Source sourceType fromLocation sourcePath _) i next -> do
let record = SR { sourceType, fromLocation, sourcePath, sourceOwner = fmap user asUser }
groups . at asProfile . non mempty <>= GR (M.singleton record mempty)
iterM (populate asProfile record) i
next
TM _ next -> next
populate
:: String
-> SourceRecord
-> Term Annotate Actions (State Groups a)
-> State Groups a
populate profile source term = case term of
TA (AA { aaUser }) action next -> do
for_ (toRecord action (fmap user aaUser)) $ \record ->
assign (groups.ix profile.ix source.contains record) True
next
TM _ next -> next
where
toRecord (Link src dst) = toFileRecord "link" src dst
toRecord (Copy src dst _) = toFileRecord "copy" src dst
toRecord (Template src dst _) = toFileRecord "template" src dst
toRecord (Patch src dst _) = toFileRecord "patch" src dst
toRecord (Command {}) = const Nothing
toFileRecord fileType fromSource filePath fileOwner =
Just FR { fileType, fromSource, filePath, fileOwner }
user :: UserW -> Either String Int
user (UserW (Username s)) = Left s
user (UserW (UserID n)) = Right (fromIntegral n)