Vous avez reçu un message "Your GitLab account has been locked ..." ? Pas d'inquiétude : lisez cet article https://docs.gricad-pages.univ-grenoble-alpes.fr/help/unlock/

Commit 14f5de85 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Autocommit on Mon Nov 27 23:14:29 CET 2017

parent 6acb6426
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric, ExistentialQuantification #-}
module Curly.Core.VCS where
import Curly.Core
......@@ -23,31 +23,105 @@ instance Serializable Hash where
instance Format Hash where
datum = Hash<$>getChunk 32
commitHash :: Commit -> Hash
commitHash c = hashData (serialize c)
type Commit = Compressed (Patch LibraryID Metadata,Maybe Hash)
type Branches = Map String ((PublicKey,String):+:Hash)
data VCCommand = PublishLibrary LibraryID Bytes
| PublishSource LibraryID (Signed String)
| SetBranches PublicKey (Signed Branches)
| ListBranches PublicKey (WithResponse (Maybe (Signed Branches)))
| CreateCommit Commit (WithResponse Hash)
| GetCommit Hash (WithResponse (Maybe Commit))
| GetLibrary LibraryID (WithResponse (Maybe Bytes))
| GetSource LibraryID (WithResponse (Maybe (Signed String)))
deriving (Generic,Show)
instance Serializable VCCommand; instance Format VCCommand
data VCKey o = LibraryKey LibraryID (WithResponse Bytes)
| SourceKey LibraryID (WithResponse (Signed String))
| BranchesKey PublicKey (WithResponse (Signed Branches))
| CommitKey Hash (WithResponse Commit)
| OtherKey o
deriving (Show,Generic)
instance Serializable o => Serializable (VCKey o)
instance Format o => Format (VCKey o)
instance Serializable o => Eq (VCKey o) where a==b = compare a b==EQ
instance Serializable o => Ord (VCKey o) where compare = comparing serialize
instance Functor VCKey where
map f (OtherKey o) = OtherKey (f o)
map f (LibraryKey a b) = LibraryKey a b
map f (SourceKey a b) = SourceKey a b
map f (CommitKey a b) = CommitKey a b
map f (BranchesKey a b) = BranchesKey a b
class MonadIO vc => MonadVC vc s | vc -> s where
vcStore :: Serializable a => s -> (WithResponse a -> VCKey ()) -> a -> vc ()
vcLoad :: Format a => s -> (WithResponse a -> VCKey ()) -> vc (Maybe a)
runVC :: vc a -> IO a
newtype File_VC a = File_VC (IO a)
deriving (Functor,SemiApplicative,Unit,Applicative)
instance Monad File_VC where join = coerceJoin File_VC
instance MonadIO File_VC where liftIO = File_VC
instance MonadVC File_VC String where
vcStore base k v = liftIO $ do
let keyName = pretty (serialize (k WithResponse)^.chunk)
writeSerial (base+"/"+keyName) v
vcLoad base k = liftIO $ do
let keyName = pretty (serialize (k WithResponse)^.chunk)
try (return Nothing) (Just <$> readFormat (base+"/"+keyName))
runVC (File_VC io) = io
newtype Client_VC a = Client_VC (IO a)
deriving (Functor,SemiApplicative,Unit,Applicative)
instance Monad Client_VC where join = coerceJoin Client_VC
instance MonadIO Client_VC where liftIO = Client_VC
instance MonadVC Client_VC Handle where
vcStore conn k l = liftIO $ writeHSerial conn ((True,k WithResponse),l)
vcLoad conn k = liftIO $ try (return Nothing) $ runConnection Just False conn $ do
exchange (\r -> (False,k (pMaybe r))) >>= maybe zero pure
runVC (Client_VC io) = io
pMaybe :: WithResponse (Maybe a) -> WithResponse a
pMaybe _ = WithResponse
maybeP :: WithResponse a -> WithResponse (Maybe a)
maybeP _ = WithResponse
vcServer (VCSB_Native _ st run) = do
(b,k) <- receive
logLine Verbose ("Received request "+show (b,k))
if b then case k of
LibraryKey lid _ -> receive >>= liftIO . run . vcStore st (LibraryKey lid)
SourceKey lid _ -> receive >>= liftIO . run . vcStore st (SourceKey lid)
CommitKey h _ -> receive >>= liftIO . run . vcStore st (CommitKey h)
BranchesKey pub _ -> receive >>= liftIO . run . vcStore st (BranchesKey pub)
OtherKey () -> return ()
else case k of
LibraryKey lid t -> sending (maybeP t) =<< liftIO (run $ vcLoad st (LibraryKey lid))
SourceKey lid t -> sending (maybeP t) =<< liftIO (run $ vcLoad st (SourceKey lid))
CommitKey h t -> sending (maybeP t) =<< liftIO (run $ vcLoad st (CommitKey h))
BranchesKey pub t -> sending (maybeP t) =<< liftIO (run $ vcLoad st (BranchesKey pub))
OtherKey () -> return ()
vcbStore :: (Serializable a,MonadIO m) => VCSBackend -> (WithResponse a -> VCKey ()) -> a -> m ()
vcbStore (VCSB_Native _ st run) k a = liftIO (run (vcStore st k a))
vcbLoad :: (Format a,MonadIO m) => VCSBackend -> (WithResponse a -> VCKey ()) -> m (Maybe a)
vcbLoad (VCSB_Native _ st run) k = liftIO (run (vcLoad st k))
vcbLoadP :: (Format a,MonadIO m) => VCSBackend -> (WithResponse a -> VCKey ()) -> ParserT s m a
vcbLoadP b k = vcbLoad b k >>= maybe zero return
data VCSBackend = VCSB_Curly String PortNumber
data VCSBackend = forall m s. MonadVC m s => VCSB_Native String s (forall a. m a -> IO a)
| VCSB_None
deriving (Eq,Ord)
instance Eq VCSBackend where a == b = compare a b == EQ
instance Ord VCSBackend where
compare (VCSB_Native s _ _) (VCSB_Native s' _ _) = compare s s'
compare (VCSB_Native _ _ _) _ = LT
compare VCSB_None VCSB_None = EQ
compare VCSB_None _ = GT
nativeBackend :: MonadIO m => String -> PortNumber -> m VCSBackend
nativeBackend h p = do
conn <- liftIO (connectTo h p)
return (VCSB_Native ("curly-vc://"+h+":"+show p) conn (\(Client_VC io) -> io))
instance Show VCSBackend where
show (VCSB_Curly h p) = "curly-vc://"+h+":"+show p
show (VCSB_Native s _ _) = s
show VCSB_None = "none"
instance Read VCSBackend where
readsPrec _ = readsParser $ backend
where backend = curlyBackend <+? fill VCSB_None (several "none")
curlyBackend = do
several "curly-vc://" <+? single '@'
liftA2 VCSB_Curly
map (by thunk) $ liftA2 nativeBackend
(many1' (noneOf ":") <&> \x -> if x=="_" then "127.0.0.1" else x)
(option' 5402 (single ':' >> number))
......@@ -55,9 +129,9 @@ curlyVCSBackend :: VCSBackend
curlyVCSBackend = fromMaybe (getDefaultVCS^.thunk) (matches Just readable (envVar "" "CURLY_VCS"))
where getDefaultVCS = do
lns <- map words . lines <$> readProcess "/usr/lib/curly/default-vcs" [] ""
return $ case lns of
([h,p]:_) -> VCSB_Curly h (fromInteger $ read p)
_ -> VCSB_None
case lns of
([h,p]:_) -> nativeBackend h (fromInteger $ read p)
_ -> return VCSB_None
curlyPublisher :: String
curlyPublisher = envVar "" "CURLY_PUBLISHER"
......@@ -66,9 +140,6 @@ getVCSBranches :: MonadIO m => String -> m Branches
getVCSBranches name = do
u <- lookup name <$> getKeyStore
case (curlyVCSBackend,u) of
(VCSB_Curly h p,Just (_,pub,_,_,_)) -> do
conn <- liftIO $ connectTo h p
map (fromMaybe zero) $ runConnection Just True conn $ do
bs <- exchange (ListBranches pub)
maybe zero (return . unsafeExtractSigned) bs
(VCSB_Native _ st run,Just (_,pub,_,_,_)) -> liftIO $ do
map (maybe zero unsafeExtractSigned) $ run $ vcLoad st (BranchesKey pub)
_ -> return zero
......@@ -29,6 +29,6 @@ executable curly-dht
GeneralizedNewtypeDeriving
RankNTypes
other-extensions: DeriveGeneric, TypeFamilies, ScopedTypeVariables, PatternSynonyms, ViewPatterns
build-depends: base, definitive-base, definitive-parser, definitive-network, curly-kademlia, curly-core
build-depends: base >=4.9 && <4.10,curly-core >=0.2 && <0.3,curly-kademlia >=1.1 && <1.2,definitive-base >=2.6 && <2.7,definitive-network >=1.4 && <1.5,definitive-parser >=2.4 && <2.5
hs-source-dirs: src
default-language: Haskell2010
......@@ -19,78 +19,13 @@ import qualified Prelude as P
instance Functor OptDescr where map = P.fmap
class Monad m => MonadVC m s | m -> s where
handleVCRequest :: (Bytes -> IO ()) -> s -> VCCommand -> m ()
newtype Command m a = Command { runCommand :: (IO :.: m) a }
deriving (Functor,Unit,SemiApplicative,Applicative)
instance (Monad m,Traversable m) => Monad (Command m) where join = coerceJoin Command
dhtAction :: Unit m => IO a -> Command m a
dhtAction = Command . Compose . map pure
newtype DHT_VC m a = DHT_VC { runDHT_VC :: Command m a }
deriving (Functor,Unit,SemiApplicative,Applicative)
instance (Monad m,Traversable m) => Monad (DHT_VC m) where join = coerceJoin DHT_VC
instance (Monad m,Traversable m) => MonadVC (DHT_VC m) (DHTInstance Key Val) where
handleVCRequest wr dht x = DHT_VC . dhtAction $ let ?write = wr in case x of
PublishLibrary lid l -> do
insertMP dht (LibraryKey lid) l
PublishSource lid s -> do
insertMP dht (SourceKey lid) s
GetLibrary l t -> do
sending t =<< lookupMP dht (LibraryKey l)
GetSource lid t -> do
sending t =<< lookupMP dht (SourceKey lid)
SetBranches pub bs -> do
insertMP dht (BranchesKey pub) bs
CreateCommit c t -> do
let h = hashData (serialize c)
insertMP dht (CommitKey h) c
sending t h
GetCommit h t -> do
sending t =<< lookupMP dht (CommitKey h)
ListBranches pub t -> do
sending t =<< lookupMP dht (BranchesKey pub)
newtype File_VC m a = File_VC { runFile_VC :: Command m a }
deriving (Functor,Unit,SemiApplicative,Applicative)
instance (Monad m,Traversable m) => Monad (File_VC m) where join = coerceJoin File_VC
storeFile :: Serializable a => String -> (WithResponse a -> Key) -> a -> IO ()
storeFile base k v = do
let keyName = pretty (serialize (k WithResponse)^.chunk)
writeSerial (base+"/"+keyName) v
loadFile :: Format a => String -> (WithResponse a -> Key) -> IO (Maybe a)
loadFile base k = do
let keyName = pretty (serialize (k WithResponse)^.chunk)
try (return Nothing) (Just <$> readFormat (base+"/"+keyName))
instance (Monad m,Traversable m) => MonadVC (File_VC m) String where
handleVCRequest wr path x = File_VC . dhtAction $ let ?write = wr in case x of
PublishLibrary lid l -> storeFile path (LibraryKey lid) l
PublishSource lid s -> storeFile path (SourceKey lid) s
GetLibrary l t -> sending t =<< loadFile path (LibraryKey l)
GetSource lid t -> sending t =<< loadFile path (SourceKey lid)
SetBranches pub bs -> storeFile path (BranchesKey pub) bs
CreateCommit c t -> do
let h = hashData (serialize c)
storeFile path (CommitKey h) c
sending t h
GetCommit h t -> sending t =<< loadFile path (CommitKey h)
ListBranches pub t -> sending t =<< loadFile path (BranchesKey pub)
data VCBackend = forall m s. MonadVC m s => VCBackend s (m () -> IO ())
vcRequest wr (VCBackend s cast) cmd = cast (handleVCRequest wr s cmd)
data Key = NodeKey String
| DataKey ValID
| LibraryKey LibraryID (WithResponse Bytes)
| SourceKey LibraryID (WithResponse (Signed String))
| BranchesKey PublicKey (WithResponse (Signed Branches))
| CommitKey Hash (WithResponse Commit)
deriving (Show,Generic)
instance Serializable Key ; instance Format Key
instance Eq Key where a==b = compare a b==EQ
instance Ord Key where compare = comparing serialize
instance DHTIndex Key
instance DHTIndex (VCKey DHTKey)
data DHTKey = DataKey ValID
| NodeKey String
deriving (Eq,Ord,Generic)
instance Serializable DHTKey ; instance Format DHTKey
type Key = VCKey DHTKey
newtype ValID = ValID Hash
deriving (Eq,Ord,Show,Generic)
......@@ -104,6 +39,15 @@ instance Eq Val where a==b = compare a b==EQ
instance Ord Val where compare = comparing serialize
instance DHTValue Val
newtype DHT_VC a = DHT_VC { runDHT_VC :: IO a }
deriving (Functor,Unit,SemiApplicative,Applicative)
instance Monad DHT_VC where join = coerceJoin DHT_VC
instance MonadIO DHT_VC where liftIO = DHT_VC
instance MonadVC DHT_VC (DHTInstance Key Val) where
vcStore st k = insertMP st (map2 (const undefined) k)
vcLoad st k = lookupMP st (map2 (const undefined) k)
runVC (DHT_VC a) = a
valID :: Val -> ValID
valID = ValID . hashData . serialize
......@@ -115,10 +59,10 @@ parMap k ta = for ta $ \a -> do
insertMPBytes :: DHTInstance Key Val -> Bytes -> IO ValID
insertMPBytes dht b
| bytesSize b<=256 = let v = DataVal b ; cid = valID v in insertDHT dht (DataKey cid) v >> return cid
| bytesSize b<=256 = let v = DataVal b ; cid = valID v in insertDHT dht (OtherKey (DataKey cid)) v >> return cid
| otherwise = let parts = mapAccum_ (\n b -> swap $ splitAt n b) (take 8 $ repeat ((bytesSize b + 7) `div` 8)) b
in parMap (insertMPBytes dht) parts >>= \ps -> let v = PartialVal ps ; cid = valID v
in cid `seq` insertDHT dht (DataKey cid) v >> return cid
in cid `seq` insertDHT dht (OtherKey (DataKey cid)) v >> return cid
lookupMPBytes :: DHTInstance Key Val -> Key -> IO (Maybe Bytes)
lookupMPBytes dht k = do
......@@ -126,7 +70,7 @@ lookupMPBytes dht k = do
case x of
Just (DataVal b,_) -> return (Just b)
Just (PartialVal ks,_) -> do
parts <- parMap (lookupMPBytes dht . DataKey) ks
parts <- parMap (lookupMPBytes dht . OtherKey . DataKey) ks
return (fold <$> sequence parts)
Nothing -> return Nothing
......@@ -135,7 +79,7 @@ lookupMP dht fk = liftIO $ lookupMPBytes dht (fk WithResponse) <&> (>>= matches
insertMP :: (Serializable a,MonadIO m) => DHTInstance Key Val -> (WithResponse a -> Key) -> a -> m ()
insertMP dht fk a = liftIO $ insertMPBytes dht (serialize a) >>= \cid -> insertDHT dht (fk WithResponse) (PartialVal [cid])
isValidAssoc (DataKey h) v = valID v == h
isValidAssoc (OtherKey (DataKey h)) v = valID v == h
isValidAssoc _ _ = True
data DHTAction = DHTBackend PortNumber String PortNumber
......@@ -160,25 +104,23 @@ main = do
case concat args of
Help:_ -> putStrLn (usageInfo "curly-vc" dhtOpts)
Action a:_ -> do
let dhtInstance dhtport = newDHTInstance (fromIntegral dhtport) (NodeKey ("curly-vc "+show dhtport)) isValidAssoc
let dhtInstance dhtport = newDHTInstance (fromIntegral dhtport) (OtherKey (NodeKey ("curly-vc "+show dhtport))) isValidAssoc
backend <- case a of
DHTRoot port -> do
dht <- dhtInstance port
return (VCBackend dht (\(DHT_VC (Command (Compose m))) -> getId<$>m))
return (VCSB_Native "dht://" dht (\(DHT_VC m) -> m))
DHTBackend port srv srv_port -> do
dht <- dhtInstance port
res <- joinDHT dht (DHTNode srv srv_port (NodeKey ("curly-vc "+show srv_port)))
res <- joinDHT dht (DHTNode srv srv_port (OtherKey (NodeKey ("curly-vc "+show srv_port))))
case res of
JoinSucces -> putStrLn $ "Successfully joined network node "+srv+":"+show srv_port
_ -> error "Couldnt't reach root node"
return (VCBackend dht (\(DHT_VC (Command (Compose m))) -> getId<$>m))
return (VCSB_Native "dht://" dht (\(DHT_VC m) -> m))
FileBackend base -> do
return (VCBackend base (\(File_VC (Command (Compose m))) -> getId<$>m))
return (VCSB_Native base base (\(File_VC m) -> m))
sock <- listenOn 5402
forever $ do
(h,_) <- accept sock
void $ forkIO $ runConnection_ True h $ forever $ do
x <- receive
liftIO (vcRequest ?write backend x)
void $ forkIO $ runConnection_ True h $ forever $ vcServer backend
......@@ -34,14 +34,6 @@ library
Network.Kademlia.ReplyQueue,
Network.Kademlia.Implementation
build-depends: base >= 4.7 && < 5,
network >=2.6 && <2.7,
mtl >=2.1.3.1,
bytestring >=0.10.2 && <0.11,
transformers >=0.3,
containers >=0.5.5.1,
stm >=2.4.3,
transformers-compat >=0.3.3
build-depends: base >=4.9 && <4.10,bytestring >=0.10 && <0.11,containers >=0.5 && <0.6,mtl >=2.2 && <2.3,network >=2.6 && <2.7,stm >=2.4 && <2.5,transformers >=0.5 && <0.6,transformers-compat >=0.5 && <0.6
hs-source-dirs: src
default-language: Haskell2010
......@@ -53,11 +53,9 @@ t'IOTgt _ x = return x
initCurly = do
setLocaleEncoding utf8
case curlyVCSBackend of
VCSB_Curly srv port -> do
conn <- connectTo srv port
let
getBranches pub = maybe zero unsafeExtractSigned <$> exchange (ListBranches pub)
trylogLevel Verbose (return ()) $ do
let conn = curlyVCSBackend
getBranches pub = maybe zero unsafeExtractSigned <$> vcbLoad conn (BranchesKey pub)
deepBranch' Nothing = return Nothing
deepBranch' (Just (Right h)) = return (Just h)
deepBranch' (Just (Left (pub,b))) = deepBranch b pub
......@@ -65,27 +63,24 @@ initCurly = do
bs <- getBranches pub
deepBranch' (lookup b bs)
getAll (Just c) = cachedCommit c $ do
comm <- exchange (GetCommit c)
comm <- vcbLoad conn (CommitKey c)
case comm of
Just (Compressed (p,mh)) -> patch p <$> getAll mh
Nothing -> do zero
Nothing -> do error "Could not reconstruct the commit chain for commit"
getAll Nothing = return zero
cachedCommit c def = do
let commitFile = curlyCommitDir </> show (Zesty c)+".index"
x <- liftIO $ try (return Nothing) (map (Just . unCompressed) $ readFormat commitFile)
maybe (def <*= liftIO . writeSerial commitFile . Compressed) return x
getLs = map (maybe [] id) $ runConnection Just False conn $ do
getLs = do
ks <- getKeyStore
branches <- map fold $ for (ks^.ascList) $ \(l,(_,pub,_,_,_)) -> do
map (first (pub,)) . by ascList <$> getBranches pub
map (by ascList . concat) $ for branches $ \((pub,b),h) -> getAll =<< deepBranch' (Just h)
getL lid = map (maybe zero id) $ runConnection Just False conn $ do
fromMaybe zero <$> exchange (GetLibrary lid)
runAtomic repositories (modify (touch (CustomRepo "curly-vc://" getLs getL)))
_ -> return ()
getL lid = fromMaybe zero <$> vcbLoad conn (LibraryKey lid)
runAtomic repositories (modify (touch (CustomRepo "curly-vc://" getLs getL)))
ioTgt = return . IOTgt
forkTgt m = do
v <- newEmptyMVar
......
......@@ -40,20 +40,17 @@ vcsDoc = unlines [
ul l = format "{ul %s}" (intercalate " " l)
vcsCmd = withDoc vcsDoc $ False <$ do
cmd <- expected "keyword, either 'commit', 'list' or 'get-source'" (nbhsp >> dirArg)
conn <- case curlyVCSBackend of
VCSB_Curly h p -> liftIO $ connectTo h p
_ -> guardWarn "no VCS backend" False >> zero
u <- lookup curlyPublisher <$> getKeyStore
let withKeys k = case u of
Just (_,pub,Just priv,_,_) -> k pub priv
_ -> serveStrLn (format "Error: the publisher %s doesn't have a private key" curlyPublisher) >> zero
modifyBranches :: (?write :: Bytes -> IO ()) => (Branches -> ParserT Bytes (OpParser IO) Branches) -> ParserT Bytes (OpParser IO) ()
modifyBranches :: (Branches -> OpParser IO Branches) -> OpParser IO ()
modifyBranches k = withKeys $ \pub priv -> do
bs <- getBranches pub
x <- k bs
bs' <- signValue priv x
send (SetBranches pub bs')
getBranches pub = maybe zero unsafeExtractSigned <$> exchange (ListBranches pub)
vcbStore conn (BranchesKey pub) bs'
getBranches pub = maybe zero unsafeExtractSigned <$> vcbLoad conn (BranchesKey pub)
deepBranch' Nothing = return Nothing
deepBranch' (Just (Right h)) = return (Just h)
deepBranch' (Just (Left (pub,b))) = deepBranch b pub
......@@ -68,21 +65,24 @@ vcsCmd = withDoc vcsDoc $ False <$ do
pathtail <- many' (nbhsp >> dirArg) <* hspc <* lookingAt (eol+eoi)
path <- getSession wd <&> (`subPath`pathtail)
let libs = ?mountain ^?? atMs path.traverse
runConnection_ True conn $ do
for_ libs $ \lib -> do
serveStrLn $ format "Committing library %s" (show (lib^.flID))
send (PublishLibrary (lib^.flID) (lib^.flBytes))
for_ (lib^.flSource) $ \s -> do
serveStrLn $ format "Committing source for library %s" (show (lib^.flID))
withKeys $ \_ priv -> do
s' <- signValue priv s
send (PublishSource (lib^.flID) s')
serveStrLn $ format "Committing new libraries to the '%s' branch" branch
modifyBranches $ \bs -> do
mh <- deepBranch' (lookup branch bs)
commid <- exchange (CreateCommit (Compressed (Patch [] [(fl^.flID,fl^.flLibrary.metadata) | fl <- libs]
,mh)))
return (insert branch (Right commid) bs)
for_ libs $ \lib -> do
serveStrLn $ format "Committing library %s" (show (lib^.flID))
vcbStore conn (LibraryKey (lib^.flID)) (lib^.flBytes)
for_ (lib^.flSource) $ \s -> do
serveStrLn $ format "Committing source for library %s" (show (lib^.flID))
withKeys $ \_ priv -> do
s' <- signValue priv s
vcbStore conn (SourceKey (lib^.flID)) s'
serveStrLn $ format "Committing new libraries to the '%s' branch" branch
modifyBranches $ \bs -> do
mh <- deepBranch' (lookup branch bs)
let c = Compressed (Patch [] [(fl^.flID,fl^.flLibrary.metadata) | fl <- libs]
,mh)
commid = commitHash c
vcbStore conn (CommitKey commid) c
return (insert branch (Right commid) bs)
"list" -> do
keyid <- expected "key name" (nbhsp >> dirArg)
......@@ -90,22 +90,17 @@ vcsCmd = withDoc vcsDoc $ False <$ do
template <- option' Nothing (Just <$> docLine "template" [])
lookingAt (hspc >> (eol+eoi))
key <- lookup keyid <$> getKeyStore
case (map (by l'2) key,curlyVCSBackend) of
(Nothing,_) -> serveStrLn $ format "Error: Unknown key %s" keyid
(Just pub,VCSB_Curly h p) -> withMountain $ liftIO $ do
conn <- connectTo h p
case branch of
Nothing -> do
m <- map (maybe zero unsafeExtractSigned) $ runConnection id True conn $ do
exchange (ListBranches pub)
serveStrLn $ intercalate " " (keys m)
Just b -> do
bs <- runConnection id True conn $ do
getAll b =<< deepBranch b pub
forl_ (ascList.each) bs $ \(lid,m) -> do
for_ (maybe (Just $ pretty m) (showTemplate m) template) $ \s ->
serveStrLn $ format "%s %s" (show lid) s
(Just _,_) -> unit
case map (by l'2) key of
Nothing -> serveStrLn $ format "Error: Unknown key %s" keyid
Just pub -> withMountain $ case branch of
Nothing -> do
m <- map (maybe zero unsafeExtractSigned) $ vcbLoad conn (BranchesKey pub)
serveStrLn $ intercalate " " (keys m)
Just b -> do
bs <- getAll b =<< deepBranch b pub
forl_ (ascList.each) bs $ \(lid,m) -> do
for_ (maybe (Just $ pretty m) (showTemplate m) template) $ \s ->
serveStrLn $ format "%s %s" (show lid) s
"get" -> do
guardWarn "You must have almighty access to retrieve arbitrary files" (?access >= Almighty)
......@@ -113,15 +108,14 @@ vcsCmd = withDoc vcsDoc $ False <$ do
<+? fill False (several "source")))
file <- expected "file name" (nbhsp >> dirArg)
lid <- expected "library ID" (nbhsp >> libID)
runConnection_ True conn $
(if getLib then getLibrary else getSource) file lid
(if getLib then getLibrary else getSource) file lid
"checkout" -> do
guardWarn "Checkouts can only be performed with almighty access" (?access >= Almighty)
(root,name) <- splitFileName <$> expected "file prefix" (nbhsp >> dirArg)
let pref = root+name
lid <- expected "library ID" (nbhsp >> libID)
ls <- maybe zero return =<< runConnection Just True conn (checkout pref lid)
ls <- checkout pref lid
liftIO $ do
writeString (root+name+".cyx") $ unlines [
"#!/usr/bin/curly",
......@@ -157,12 +151,14 @@ vcsCmd = withDoc vcsDoc $ False <$ do
| (Just _,l) <- groups^.ascList]
pred <- expected "filter predicate" (nbhsp >> (libPred <+? singlePred <+? groupPred))
lookingAt (hspc >> (eol+eoi))
runConnection_ True conn $ modifyBranches $ \bs -> do
modifyBranches $ \bs -> do
mh <- deepBranch' (lookup branch bs)
index <- getAll branch mh
let index' = warp ascList pred index
dff = diff index index'
commid <- exchange (CreateCommit (Compressed (dff,mh)))
c = Compressed (dff,mh)
commid = commitHash c
vcbStore conn (CommitKey commid) c
return (insert branch (Right commid) bs)
branchFork = do
isLink <- nbhsp >> (fill False (several "fork") <+? fill True (several "link"))
......@@ -171,27 +167,27 @@ vcsCmd = withDoc vcsDoc $ False <$ do
map (lookup user) getKeyStore >>= \x -> case x of
Nothing -> do serveStrLn $ format "Error: unknown user %s" user
zero
Just (_,pub,_,_,_) -> do
runConnection_ True conn $ modifyBranches $ \bs -> do
if isLink then return (insert branch (Left (pub,srcBranch)) bs)
else do
bs' <- getBranches pub
return (bs & set (at branch) (bs'^.at srcBranch))
Just (_,pub,_,_,_) -> modifyBranches $ \bs -> do
if isLink then return (insert branch (Left (pub,srcBranch)) bs)
else do
bs' <- getBranches pub
return (bs & set (at branch) (bs'^.at srcBranch))
branchFork <+? branchFilter
_ -> guardWarn "Expected 'commit', 'list', 'get-library' or 'get-source'" False
where libID = searchID <+? (dirArg >*> readable)
where conn = curlyVCSBackend
libID = searchID <+? (dirArg >*> readable)
createFileDir f = createDirectoryIfMissing True (dropFileName f)
getSource file lid = do
x <- exchange (GetSource lid)
x <- vcbLoad conn (SourceKey lid)
case x of
Just s -> liftIO $ do
createFileDir file
writeString file (unsafeExtractSigned s)
Nothing -> serveStrLn $ format "Error: the source for library %s doesn't seem to exist" (show lid)
getLibrary file lid = do
x <- exchange (GetLibrary lid)
x <- vcbLoad conn (LibraryKey lid)
case x of
Just s -> when (isLibData lid s) $ liftIO $ do
createFileDir file
......@@ -210,7 +206,7 @@ vcsCmd = withDoc vcsDoc $ False <$ do
checkoutMod [] ctx
getAll b (Just c) = cachedCommit c $ do
comm <- exchange (GetCommit c)
comm <- vcbLoad conn (CommitKey c)
case comm of
Just (Compressed (p,mh)) -> patch p <$> getAll b mh
Nothing -> do serveStrLn (format "Couldn't reconstruct the commit history for branch %s" b)
......
......@@ -17,7 +17,6 @@ cabal-version: >=1.10
-- library
-- default-language: Haskell2010
-- exposed-modules: