{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, TypeApplications, MonoLocalBinds, DataKinds #-}
module Aura.State
( PkgState(..)
, saveState
, restoreState
, inState
, readState
, stateCache
, getStateFiles
) where
import Aura.Cache
import Aura.Colour (red)
import Aura.Core (warn, notify, liftEitherM, report)
import Aura.Languages
import Aura.Pacman (pacmanOutput, pacman)
import Aura.Settings
import Aura.Types
import Aura.Utils
import BasePrelude hiding (Version, mapMaybe)
import Control.Error.Util (hush)
import Control.Monad.Freer
import Control.Monad.Freer.Error
import Control.Monad.Freer.Reader
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Generics.Product (field)
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Time
import Data.Versions
import Data.Witherable (mapMaybe)
import Lens.Micro ((^.))
import System.Path
import System.Path.IO (createDirectoryIfMissing, getDirectoryContents)
data PkgState = PkgState { timeOf :: ZonedTime, pinnedOf :: Bool, pkgsOf :: M.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 (Object v) = PkgState
<$> v .: "time"
<*> v .: "pinned"
<*> fmap f (v .: "packages")
where f = mapMaybe (hush . versioning)
parseJSON invalid = typeMismatch "PkgState" invalid
data StateDiff = StateDiff { _toAlter :: [SimplePkg], _toRemove :: [PkgName] }
stateCache :: Path Absolute
stateCache = fromAbsoluteFilePath "/var/cache/aura/states"
inState :: SimplePkg -> PkgState -> Bool
inState (SimplePkg n v) s = maybe False (v ==) . M.lookup n $ pkgsOf s
rawCurrentState :: IO [SimplePkg]
rawCurrentState = mapMaybe (simplepkg' . strictText) . BL.lines <$> pacmanOutput ["-Q"]
currentState :: IO PkgState
currentState = do
pkgs <- rawCurrentState
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 [Path Absolute]
getStateFiles = do
createDirectoryIfMissing True stateCache
sort . map (stateCache </>) <$> getDirectoryContents stateCache
saveState :: Settings -> IO ()
saveState ss = do
state <- currentState
let filename = stateCache </> fromUnrootedFilePath (dotFormat (timeOf state)) <.> FileExt "json"
createDirectoryIfMissing True stateCache
BL.writeFile (toFilePath filename) $ encode state
notify ss . saveState_1 $ langOf ss
dotFormat :: ZonedTime -> String
dotFormat (ZonedTime t _) = 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 :: (Member (Reader Settings) r, Member (Error Failure) r, Member IO r) => Eff r ()
restoreState = send getStateFiles >>= maybe (throwError $ Failure restoreState_2) f . nonEmpty
where f sfs = do
ss <- ask
let pth = either id id . cachePathOf $ commonConfigOf ss
mpast <- send $ selectState sfs >>= readState
case mpast of
Nothing -> throwError $ Failure readState_1
Just past -> do
curr <- send currentState
Cache cache <- send $ cacheContents pth
let StateDiff rein remo = compareStates past curr
(okay, nope) = partition (`M.member` cache) rein
traverse_ (report red restoreState_1 . fmap (^. field @"name")) $ nonEmpty nope
reinstallAndRemove (mapMaybe (`M.lookup` cache) okay) remo
selectState :: NonEmpty (Path Absolute) -> IO (Path Absolute)
selectState = getSelection (T.pack . toFilePath)
readState :: Path Absolute -> IO (Maybe PkgState)
readState = fmap decode . BL.readFile . toFilePath
reinstallAndRemove :: (Member (Reader Settings) r, Member (Error Failure) r, Member IO r) =>
[PackagePath] -> [PkgName] -> Eff r ()
reinstallAndRemove [] [] = ask >>= \ss -> send (warn ss . reinstallAndRemove_1 $ langOf ss)
reinstallAndRemove down remo
| null remo = reinstall
| null down = remove
| otherwise = reinstall *> remove
where remove = liftEitherM . pacman $ "-R" : asFlag remo
reinstall = liftEitherM . pacman $ "-U" : map (toFilePath . path) down