module Aura.State
( PkgState(..)
, saveState
, restoreState
, inState
, readState
, stateCache
, getStateFiles
) where
import Aura.Cache
import Aura.Colour (red)
import Aura.Core (Env(..), notify, report, warn)
import Aura.IO
import Aura.Languages
import Aura.Pacman (pacman, pacmanLines)
import Aura.Settings
import Aura.Types
import Aura.Utils (hush)
import Data.Aeson
import Data.Versions
import RIO
import qualified RIO.ByteString.Lazy as BL
import RIO.Directory
import RIO.FilePath
import qualified RIO.List as L
import RIO.List.Partial ((!!))
import qualified RIO.Map as M
import qualified RIO.Map.Unchecked as M
import qualified RIO.NonEmpty as NEL
import qualified RIO.Text as T
import RIO.Time
import Text.Printf (printf)
data PkgState = PkgState
{ timeOf :: !ZonedTime
, pinnedOf :: !Bool
, pkgsOf :: !(Map PkgName Versioning) }
instance ToJSON PkgState where
toJSON (PkgState t pnd ps) = object
[ "time" .= t
, "pinned" .= pnd
, "packages" .= fmap prettyV ps ]
instance FromJSON PkgState where
parseJSON = withObject "PkgState" $ \v -> PkgState
<$> v .: "time"
<*> v .: "pinned"
<*> fmap f (v .: "packages")
where f = M.mapMaybe (hush . versioning)
data StateDiff = StateDiff
{ _toAlter :: ![SimplePkg]
, _toRemove :: ![PkgName] }
stateCache :: FilePath
stateCache = "/var/cache/aura/states"
inState :: SimplePkg -> PkgState -> Bool
inState (SimplePkg n v) s = (Just v ==) . M.lookup n $ pkgsOf s
rawCurrentState :: Environment -> IO [SimplePkg]
rawCurrentState env = mapMaybe simplepkg' <$> pacmanLines env ["-Q"]
currentState :: Environment -> IO PkgState
currentState env = do
pkgs <- rawCurrentState env
time <- getZonedTime
pure . PkgState time False . M.fromAscList $ map (\(SimplePkg n v) -> (n, v)) pkgs
compareStates :: PkgState -> PkgState -> StateDiff
compareStates old curr = tcar { _toAlter = olds old curr <> _toAlter tcar }
where tcar = toChangeAndRemove old curr
toChangeAndRemove :: PkgState -> PkgState -> StateDiff
toChangeAndRemove old curr = uncurry StateDiff . M.foldrWithKey status ([], []) $ pkgsOf curr
where status k v (d, r) = case M.lookup k (pkgsOf old) of
Nothing -> (d, k : r)
Just v' | v == v' -> (d, r)
| otherwise -> (SimplePkg k v' : d, r)
olds :: PkgState -> PkgState -> [SimplePkg]
olds old curr = map (uncurry SimplePkg) . M.assocs $ M.difference (pkgsOf old) (pkgsOf curr)
getStateFiles :: IO [FilePath]
getStateFiles = do
createDirectoryIfMissing True stateCache
L.sort . map (stateCache </>) <$> listDirectory stateCache
saveState :: Settings -> IO ()
saveState ss = do
state <- currentState $ envOf ss
let filename = stateCache </> dotFormat (timeOf state) <.> "json"
createDirectoryIfMissing True stateCache
BL.writeFile filename $ encode state
notify ss saveState_1
dotFormat :: ZonedTime -> String
dotFormat (ZonedTime t _) = L.intercalate "." items
where items = [ show ye
, printf "%02d(%s)" mo (mnths !! (mo - 1))
, printf "%02d" da
, printf "%02d" (todHour $ localTimeOfDay t)
, printf "%02d" (todMin $ localTimeOfDay t)
, printf "%02d" ((round . todSec $ localTimeOfDay t) :: Int) ]
(ye, mo, da) = toGregorian $ localDay t
mnths :: [String]
mnths = [ "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" ]
restoreState :: RIO Env ()
restoreState =
liftIO getStateFiles >>= maybe (throwM . Failure $ FailMsg restoreState_2) f . NEL.nonEmpty
where f :: NonEmpty FilePath -> RIO Env ()
f sfs = do
ss <- asks settings
let pth = either id id . cachePathOf $ commonConfigOf ss
mpast <- liftIO $ selectState sfs >>= readState
case mpast of
Nothing -> throwM . Failure $ FailMsg readState_1
Just past -> do
curr <- liftIO . currentState $ envOf ss
Cache cache <- liftIO $ cacheContents pth
let StateDiff rein remo = compareStates past curr
(okay, nope) = L.partition (`M.member` cache) rein
traverse_ (report red restoreState_1 . fmap spName) $ NEL.nonEmpty nope
reinstallAndRemove (mapMaybe (`M.lookup` cache) okay) remo
selectState :: NonEmpty FilePath -> IO FilePath
selectState = getSelection T.pack
readState :: FilePath -> IO (Maybe PkgState)
readState = fmap decode . BL.readFile
reinstallAndRemove :: [PackagePath] -> [PkgName] -> RIO Env ()
reinstallAndRemove [] [] = asks settings >>= \ss -> warn ss reinstallAndRemove_1
reinstallAndRemove down remo
| null remo = reinstall
| null down = remove
| otherwise = reinstall *> remove
where
remove = asks (envOf . settings) >>= \env -> liftIO . pacman env $ "-R" : asFlag remo
reinstall = asks (envOf . settings) >>= \env -> liftIO . pacman env $ "-U" : map (T.pack . ppPath) down