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 2012-10-29 00:15:43 -04:00
parent ec0bac9d73
commit 4e765327ca
18 changed files with 259 additions and 210 deletions

View file

@ -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

View file

@ -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