mywork-1.0.0.0: app/Sync.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
module Sync
-- (
-- )
where
import Control.Applicative ( (<|>) )
import Control.Monad ( filterM, foldM )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import Control.Monad.State ( evalStateT, gets, modify )
import qualified Data.HashMap.Lazy as HM
import Data.Ini
import qualified Data.List as DL
import Data.Maybe ( catMaybes )
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Time.Calendar ( Day )
import Data.Time.Clock ( getCurrentTime, utctDay )
import Path ( (</>), Path, Abs, Dir, relfile, reldir
, toFilePath, parseAbsDir, fileExtension )
import Path.IO ( doesDirExist, doesFileExist, getModificationTime
, listDir )
import Defs
data LocationStatus = LocationStatus { locExists :: Maybe Bool
, otherLocs :: [ (LType, LocationSpec) ]
, locNotes :: [ Note ]
, lastUpd :: Maybe Day
}
-- KWQ: attach LType to Location more permanently to provide more info?
data LType = GitRepo GitRemote | GitFork LType | DarcsRepo
deriving Eq
newtype GitRemote = GitRemote Text
deriving Eq
syncLocation :: MonadIO m => Location -> m LocationStatus
-- KWQ: should return a flag indicating whether there were changes (e.g. new locations found), so that the project itself can be labelled as "changed" with "save needed"
syncLocation l = case location l of
LocalSpec lcl ->
do e <- liftIO $ doesDirExist lcl
u <- if e
then Just . utctDay <$> liftIO (getModificationTime lcl)
else return Nothing
o <- getOtherLocs lcl
nts <- getLocNotes lcl
return $ LocationStatus { locExists = Just e
, otherLocs = o
, locNotes = nts
, lastUpd = u
}
RemoteSpec _ -> return LocationStatus { locExists = Nothing
, otherLocs = mempty
, locNotes = mempty
, lastUpd = Nothing
}
-- | Searches for other locations based on the current location. This will find
-- locations like remote git repos, darcs repos, etc.
--
-- These locations are added permanently to the project.
getOtherLocs :: MonadIO m => Path Abs Dir -> m [ (LType, LocationSpec) ]
getOtherLocs lcl = concat <$> sequence [ getGitLocs lcl
, getDarcsLocs lcl
]
getGitLocs :: MonadIO m => Path Abs Dir -> m [ (LType, LocationSpec) ]
getGitLocs lcl =
let gitCfgFile = lcl </> [relfile|.git/config|]
gcRemote sname cfg locs =
case T.words sname of
["remote", rmt] ->
let t = GitRepo $ GitRemote
-- drop surrounding double-quotes
$ T.drop 1 $ T.take (T.length rmt - 1) rmt
in locs <> catMaybes
[ (t,) . toLocSpec <$> HM.lookup "url" cfg
, (GitFork t,) . toLocSpec <$> HM.lookup "pushurl" cfg
]
_ -> locs
toLocSpec t = maybe (RemoteSpec t) LocalSpec $ parseAbsDir $ T.unpack t
gcProc = HM.foldrWithKey gcRemote mempty . unIni
in do ge <- liftIO (doesFileExist gitCfgFile)
if ge
then do gt <- liftIO $ TIO.readFile (toFilePath gitCfgFile)
case parseIni gt of
Left _e -> return mempty -- no error reporting
Right gc -> return $ gcProc gc
else return mempty
getDarcsLocs :: MonadIO m => Path Abs Dir -> m [ (LType, LocationSpec) ]
getDarcsLocs lcl =
let darcsRepos = lcl </> [relfile|_darcs/prefs/repos|]
mkDarcs t = ( DarcsRepo
, maybe (RemoteSpec t) LocalSpec $ parseAbsDir $ T.unpack t
)
lclExists (_,r) = case r of
RemoteSpec _ -> return True
LocalSpec d -> doesDirExist d
in do de <- liftIO (doesFileExist darcsRepos)
if de
then do rst <- liftIO $ TIO.readFile $ toFilePath darcsRepos
let rsc = mkDarcs <$> T.lines rst
filterM lclExists rsc
else return mempty
getLocNotes :: MonadIO m => Path Abs Dir -> m [ Note ]
getLocNotes lcl =
let notesDir = lcl </> [reldir|@MyWork|]
mkFileNote nl f =
case fileExtension f of
Just ".txt" ->
do nt <- liftIO $ TIO.readFile (toFilePath f)
nd <- utctDay <$> liftIO ( getModificationTime f)
return $ Note { note = nt
, notedOn = nd
, noteSource = ProjLoc
} : nl
_ -> return nl
in do ne <- liftIO (doesDirExist notesDir)
if ne
then do (_,files) <- liftIO (listDir notesDir)
foldM mkFileNote mempty files
else return mempty
applyLocSync :: Day -> LocationStatus -> Location -> Location
applyLocSync now locsts loc =
let rmtnoteTxt :: (LType, LocationSpec) -> Text
rmtnoteTxt = \case
(GitRepo (GitRemote n), r) ->
"Cloned from git repo " <> tshow n <> " @ " <> tshow r
(GitFork (GitRepo (GitRemote n)), r) ->
"Pushing to git repo " <> tshow n <> " fork @ " <> tshow r
(DarcsRepo, r) -> "Synced with darcs repo @ " <> tshow r
(_, r) -> "Related to " <> tshow r
addRmtNoteText ol cl =
-- n.b. instead of using updateNote, which prefers the new note, this
-- only adds a note if there isn't already one, preferring the existing
-- one in case it has been updated (aside from the noteTitle).
let rnt = rmtnoteTxt ol
rn = Note { note = rnt, notedOn = now, noteSource = MyWorkGenerated }
in case DL.find ((noteTitle' rnt ==) . noteTitle) (notes cl) of
Nothing -> cl { notes = rn : notes cl }
Just _ -> cl
loc1 = foldr addRmtNoteText loc $ otherLocs locsts
loc2 = foldr (updateLocNote Nothing) loc1 $ locNotes locsts
in loc2 { locValid = maybe True id $ locExists locsts
, locatedOn = lastUpd locsts <|> locatedOn loc
}
applyProjLocSync :: MonadIO m
=> Maybe LocationSpec -> Project -> Location -> m Project
applyProjLocSync mbOldL_ p_ l_ = evalStateT (go mbOldL_ p_ l_) mempty
where
go mbOldL p l =
gets (location l `elem`) >>= \case
True -> return p
False ->
do modify (location l :)
locsts <- syncLocation l
now <- utctDay <$> liftIO getCurrentTime
let p' = updateLocation mbOldL (applyLocSync now locsts l) p
let rmtspec rmtName =
DL.lookup (GitRepo (GitRemote rmtName)) $ otherLocs locsts
let mkLoc (lt,ls) =
let nts = case lt of
GitRepo (GitRemote _) -> mempty
GitFork (GitRepo (GitRemote n)) ->
[ Note { note = "Fork of git repo @ " <>
case rmtspec n of
Just rls -> tshow rls
Nothing -> "??"
, notedOn = now
, noteSource = MyWorkGenerated
}
]
DarcsRepo -> mempty
_ -> [ Note { note = "Related to " <> tshow ls
, notedOn = now
, noteSource = MyWorkGenerated
}
]
in Location { location = ls
, locatedOn = Nothing
, locValid = True
, notes = nts
}
foldM (go Nothing) p' (mkLoc <$> otherLocs locsts)
syncProject :: MonadIO m => Project -> m Project
syncProject p = foldM (applyProjLocSync Nothing) p $ locations p