Assistant monad, stage 1
This adds the Assistant monad, and an AssistantData structure. So far, none of the assistant's threads run in the monad yet.
This commit is contained in:
Joey Hess
parent
ec0bac9d73
commit
4e765327ca
18 changed files with 259 additions and 210 deletions
|
|
@ -59,16 +59,16 @@ watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan
|
|||
watchThread st dstatus transferqueue changechan = NamedThread thisThread $ do
|
||||
void $ watchDir "." ignored hooks startup
|
||||
debug thisThread [ "watching", "."]
|
||||
where
|
||||
startup = startupScan st dstatus
|
||||
hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a
|
||||
hooks = mkWatchHooks
|
||||
{ addHook = hook onAdd
|
||||
, delHook = hook onDel
|
||||
, addSymlinkHook = hook onAddSymlink
|
||||
, delDirHook = hook onDelDir
|
||||
, errHook = hook onErr
|
||||
}
|
||||
where
|
||||
startup = startupScan st dstatus
|
||||
hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a
|
||||
hooks = mkWatchHooks
|
||||
{ addHook = hook onAdd
|
||||
, delHook = hook onDel
|
||||
, addSymlinkHook = hook onAddSymlink
|
||||
, delDirHook = hook onDelDir
|
||||
, errHook = hook onErr
|
||||
}
|
||||
|
||||
{- Initial scartup scan. The action should return once the scan is complete. -}
|
||||
startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
|
||||
|
|
@ -89,7 +89,7 @@ startupScan st dstatus scanner = do
|
|||
|
||||
ignored :: FilePath -> Bool
|
||||
ignored = ig . takeFileName
|
||||
where
|
||||
where
|
||||
ig ".git" = True
|
||||
ig ".gitignore" = True
|
||||
ig ".gitattributes" = True
|
||||
|
|
@ -109,14 +109,13 @@ runHandler threadname st dstatus transferqueue changechan handler file filestatu
|
|||
Left e -> print e
|
||||
Right Nothing -> noop
|
||||
Right (Just change) -> recordChange changechan change
|
||||
where
|
||||
go = runThreadState st $ handler threadname file filestatus dstatus transferqueue
|
||||
where
|
||||
go = runThreadState st $ handler threadname file filestatus dstatus transferqueue
|
||||
|
||||
onAdd :: Handler
|
||||
onAdd _ file filestatus _ _
|
||||
| maybe False isRegularFile filestatus = pendingAddChange file
|
||||
| otherwise = noChange
|
||||
where
|
||||
|
||||
{- A symlink might be an arbitrary symlink, which is just added.
|
||||
- Or, if it is a git-annex symlink, ensure it points to the content
|
||||
|
|
@ -124,69 +123,67 @@ onAdd _ file filestatus _ _
|
|||
-}
|
||||
onAddSymlink :: Handler
|
||||
onAddSymlink threadname file filestatus dstatus transferqueue = go =<< Backend.lookupFile file
|
||||
where
|
||||
go (Just (key, _)) = do
|
||||
link <- calcGitLink file key
|
||||
ifM ((==) link <$> liftIO (readSymbolicLink file))
|
||||
( do
|
||||
s <- liftIO $ getDaemonStatus dstatus
|
||||
checkcontent key s
|
||||
ensurestaged link s
|
||||
, do
|
||||
liftIO $ debug threadname ["fix symlink", file]
|
||||
liftIO $ removeFile file
|
||||
liftIO $ createSymbolicLink link file
|
||||
checkcontent key =<< liftIO (getDaemonStatus dstatus)
|
||||
addlink link
|
||||
)
|
||||
go Nothing = do -- other symlink
|
||||
link <- liftIO (readSymbolicLink file)
|
||||
ensurestaged link =<< liftIO (getDaemonStatus dstatus)
|
||||
where
|
||||
go (Just (key, _)) = do
|
||||
link <- calcGitLink file key
|
||||
ifM ((==) link <$> liftIO (readSymbolicLink file))
|
||||
( do
|
||||
s <- liftIO $ getDaemonStatus dstatus
|
||||
checkcontent key s
|
||||
ensurestaged link s
|
||||
, do
|
||||
liftIO $ debug threadname ["fix symlink", file]
|
||||
liftIO $ removeFile file
|
||||
liftIO $ createSymbolicLink link file
|
||||
checkcontent key =<< liftIO (getDaemonStatus dstatus)
|
||||
addlink link
|
||||
)
|
||||
go Nothing = do -- other symlink
|
||||
link <- liftIO (readSymbolicLink file)
|
||||
ensurestaged link =<< liftIO (getDaemonStatus dstatus)
|
||||
|
||||
{- This is often called on symlinks that are already
|
||||
- staged correctly. A symlink may have been deleted
|
||||
- and being re-added, or added when the watcher was
|
||||
- not running. So they're normally restaged to make sure.
|
||||
-
|
||||
- As an optimisation, during the startup scan, avoid
|
||||
- restaging everything. Only links that were created since
|
||||
- the last time the daemon was running are staged.
|
||||
- (If the daemon has never ran before, avoid staging
|
||||
- links too.)
|
||||
-}
|
||||
ensurestaged link daemonstatus
|
||||
| scanComplete daemonstatus = addlink link
|
||||
| otherwise = case filestatus of
|
||||
Just s
|
||||
| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
|
||||
_ -> addlink link
|
||||
{- This is often called on symlinks that are already
|
||||
- staged correctly. A symlink may have been deleted
|
||||
- and being re-added, or added when the watcher was
|
||||
- not running. So they're normally restaged to make sure.
|
||||
-
|
||||
- As an optimisation, during the startup scan, avoid
|
||||
- restaging everything. Only links that were created since
|
||||
- the last time the daemon was running are staged.
|
||||
- (If the daemon has never ran before, avoid staging
|
||||
- links too.)
|
||||
-}
|
||||
ensurestaged link daemonstatus
|
||||
| scanComplete daemonstatus = addlink link
|
||||
| otherwise = case filestatus of
|
||||
Just s
|
||||
| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange
|
||||
_ -> addlink link
|
||||
|
||||
{- For speed, tries to reuse the existing blob for
|
||||
- the symlink target. -}
|
||||
addlink link = do
|
||||
liftIO $ debug threadname ["add symlink", file]
|
||||
v <- catObjectDetails $ Ref $ ':':file
|
||||
case v of
|
||||
Just (currlink, sha)
|
||||
| s2w8 link == L.unpack currlink ->
|
||||
stageSymlink file sha
|
||||
_ -> do
|
||||
sha <- inRepo $
|
||||
Git.HashObject.hashObject BlobObject link
|
||||
{- For speed, tries to reuse the existing blob for symlink target. -}
|
||||
addlink link = do
|
||||
liftIO $ debug threadname ["add symlink", file]
|
||||
v <- catObjectDetails $ Ref $ ':':file
|
||||
case v of
|
||||
Just (currlink, sha)
|
||||
| s2w8 link == L.unpack currlink ->
|
||||
stageSymlink file sha
|
||||
madeChange file LinkChange
|
||||
_ -> do
|
||||
sha <- inRepo $
|
||||
Git.HashObject.hashObject BlobObject link
|
||||
stageSymlink file sha
|
||||
madeChange file LinkChange
|
||||
|
||||
{- When a new link appears, or a link is changed,
|
||||
- after the startup scan, handle getting or
|
||||
- dropping the key's content. -}
|
||||
checkcontent key daemonstatus
|
||||
| scanComplete daemonstatus = do
|
||||
present <- inAnnex key
|
||||
unless present $
|
||||
queueTransfers Next transferqueue dstatus
|
||||
key (Just file) Download
|
||||
handleDrops dstatus present key (Just file)
|
||||
| otherwise = noop
|
||||
{- When a new link appears, or a link is changed, after the startup
|
||||
- scan, handle getting or dropping the key's content. -}
|
||||
checkcontent key daemonstatus
|
||||
| scanComplete daemonstatus = do
|
||||
present <- inAnnex key
|
||||
unless present $
|
||||
queueTransfers Next transferqueue dstatus
|
||||
key (Just file) Download
|
||||
handleDrops dstatus present key (Just file)
|
||||
| otherwise = noop
|
||||
|
||||
onDel :: Handler
|
||||
onDel threadname file _ _dstatus _ = do
|
||||
|
|
|
|||
|
|
@ -28,12 +28,6 @@ import Assistant.WebApp.Configurators.XMPP
|
|||
import Assistant.WebApp.Documentation
|
||||
import Assistant.WebApp.OtherRepos
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.ScanRemotes
|
||||
import Assistant.TransferQueue
|
||||
import Assistant.TransferSlots
|
||||
import Assistant.Pushes
|
||||
import Assistant.Commits
|
||||
import Utility.WebApp
|
||||
import Utility.FileMode
|
||||
import Utility.TempFile
|
||||
|
|
@ -51,51 +45,43 @@ mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
|
|||
|
||||
type Url = String
|
||||
|
||||
webAppThread
|
||||
:: Maybe ThreadState
|
||||
-> DaemonStatusHandle
|
||||
-> ScanRemoteMap
|
||||
-> TransferQueue
|
||||
-> TransferSlots
|
||||
-> PushNotifier
|
||||
-> CommitChan
|
||||
webAppThread
|
||||
:: AssistantData
|
||||
-> UrlRenderer
|
||||
-> Bool
|
||||
-> Maybe (IO String)
|
||||
-> Maybe (Url -> FilePath -> IO ())
|
||||
-> NamedThread
|
||||
webAppThread mst dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer postfirstrun onstartup = thread $ do
|
||||
webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ do
|
||||
webapp <- WebApp
|
||||
<$> pure mst
|
||||
<*> pure dstatus
|
||||
<*> pure scanremotes
|
||||
<*> pure transferqueue
|
||||
<*> pure transferslots
|
||||
<*> pure pushnotifier
|
||||
<*> pure commitchan
|
||||
<$> pure assistantdata
|
||||
<*> (pack <$> genRandomToken)
|
||||
<*> getreldir mst
|
||||
<*> getreldir
|
||||
<*> pure $(embed "static")
|
||||
<*> newWebAppState
|
||||
<*> pure postfirstrun
|
||||
<*> pure noannex
|
||||
setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
|
||||
app <- toWaiAppPlain webapp
|
||||
app' <- ifM debugEnabled
|
||||
( return $ httpDebugLogger app
|
||||
, return app
|
||||
)
|
||||
runWebApp app' $ \port -> case mst of
|
||||
Nothing -> withTempFile "webapp.html" $ \tmpfile _ ->
|
||||
runWebApp app' $ \port -> if noannex
|
||||
then withTempFile "webapp.html" $ \tmpfile _ ->
|
||||
go port webapp tmpfile Nothing
|
||||
Just st -> do
|
||||
else do
|
||||
let st = threadState assistantdata
|
||||
htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim
|
||||
urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile
|
||||
go port webapp htmlshim (Just urlfile)
|
||||
where
|
||||
thread = NamedThread thisThread
|
||||
getreldir Nothing = return Nothing
|
||||
getreldir (Just st) = Just <$>
|
||||
(relHome =<< absPath
|
||||
=<< runThreadState st (fromRepo repoPath))
|
||||
getreldir
|
||||
| noannex = return Nothing
|
||||
| otherwise = Just <$>
|
||||
(relHome =<< absPath
|
||||
=<< runThreadState (threadState assistantdata) (fromRepo repoPath))
|
||||
go port webapp htmlshim urlfile = do
|
||||
debug thisThread ["running on port", show port]
|
||||
let url = myUrl webapp port
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue