module Check.Internal where
import Check.Types
import Compiler.Types
import Constants
import CoreTypes
import qualified Data.ByteString as SB
import qualified Data.ByteString.Char8 as SBC
import qualified Data.ByteString.Lazy as LB
import qualified Data.Digest.Pure.MD5 as H (md5)
import Data.Maybe (catMaybes)
import System.Directory (getDirectoryContents)
import System.Exit (ExitCode (..))
import System.FilePath ((</>))
import System.Posix.Files (fileExist, getSymbolicLinkStatus,
isBlockDevice, isCharacterDevice,
isDirectory, isNamedPipe, isRegularFile,
isSocket, isSymbolicLink,
readSymbolicLink)
import System.Process (readProcess, system)
checkDeployment :: DiagnosedDeployment -> DeploymentCheckResult
checkDeployment (Diagnosed [] (D dst _ _) _)
= ImpossibleDeployment [unwords ["No source for deployment with destination", dst]]
checkDeployment (Diagnosed srcs dst kind)
= bestResult $ map (\src -> checkSingle src dst kind) srcs
bestResult :: [CheckResult] -> DeploymentCheckResult
bestResult cs
| all impossible cs = ImpossibleDeployment $ map (\(Impossible s) -> s) cs
| otherwise
= case head $ dropWhile impossible cs of
AlreadyDone -> DeploymentDone
Ready i -> ReadyToDeploy i
Dirty s i c -> DirtySituation s i c
Impossible _ -> error "Cannot be the case"
impossible :: CheckResult -> Bool
impossible (Impossible _) = True
impossible _ = False
impossibleDeployment :: DeploymentCheckResult -> Bool
impossibleDeployment (ImpossibleDeployment _) = True
impossibleDeployment _ = False
dirtyDeployment :: DeploymentCheckResult -> Bool
dirtyDeployment (DirtySituation _ _ _) = True
dirtyDeployment _ = False
deploymentReadyToDeploy :: DeploymentCheckResult -> Bool
deploymentReadyToDeploy (ReadyToDeploy _) = True
deploymentReadyToDeploy _ = False
deploymentIsDone :: DeploymentCheckResult -> Bool
deploymentIsDone DeploymentDone = True
deploymentIsDone _ = False
checkSingle :: DiagnosedFp -> DiagnosedFp -> DeploymentKind -> CheckResult
checkSingle (D src srcd srch) (D dst dstd dsth) kind =
case (srcd, dstd, kind) of
(IsFile , Nonexistent , _ ) -> ready
(IsFile , IsFile , LinkDeployment)
-> e ["Both the source:", src, "and the destination:", dst, "are files for a link deployment."]
(IsFile , IsFile , CopyDeployment)
-> if srch == dsth
then AlreadyDone
else e ["Both the source:", src, "and the destination:", dst, "are files for a copy deployment, but they are not equal."]
(IsFile , IsDirectory , _)
-> e ["The source: ", src, "is a file but the destination:", dst, "is a directory."]
(IsFile , IsLinkTo l , LinkDeployment)
-> if l == src
then AlreadyDone
else e ["The source:", src, "is a file and the destination:", dst, "is a link for a link deployment but the destination does not point to the source. Instead it points to:", l ++ "."]
(IsFile , IsLinkTo _ , CopyDeployment)
-> e ["The source:", src, "is a file and the destination:", dst, "is a link for a copy deployment."]
(IsDirectory, Nonexistent , _ ) -> ready
(IsDirectory, IsFile , _ )
-> e ["The source:", src, "is a directory and the destination:", dst, "is a file."]
(IsDirectory, IsDirectory , CopyDeployment)
-> if srch == dsth
then AlreadyDone
else e ["The source:", src, "and destination:", dst, "are directories for a copy deployment, but they are not equal."]
(IsDirectory, IsDirectory , LinkDeployment)
-> e ["The source:", src, "and the destination:", dst, "are directories for a link deployment."]
(IsDirectory, IsLinkTo l , LinkDeployment)
-> if l == src
then AlreadyDone
else e ["The source:", src, "is a directory and the destination:", dst, "is a link for a link deployment but the destination does not point to the source. Instead it points to:", l ++ "."]
(IsDirectory, IsLinkTo _ , CopyDeployment)
-> e ["The source:", src, "is a directory and the destination:", dst, "is a link for a copy deployment."]
(Nonexistent, _ , _ )
-> i ["The source:", src, "does not exist."]
(IsLinkTo _ , _ , _ )
-> i ["The source:", src, "is a link."]
(IsWeird , IsWeird , _ )
-> i ["Both the source:", src, "and the destination:", dst, "are weird."]
(IsWeird , _ , _ )
-> i ["The source:", src, "is weird."]
(_ , IsWeird , _ )
-> i ["The destination:", dst, "is weird."]
where
ins = Instruction src dst kind
ready = Ready ins
i = Impossible . unlines
e s = Dirty (unlines s) ins cins
cins = case dstd of
IsFile -> CleanFile dst
IsLinkTo _ -> CleanLink dst
IsDirectory -> CleanDirectory dst
_ -> error "should not occur"
diagnoseDeployment :: Deployment -> IO DiagnosedDeployment
diagnoseDeployment (Put srcs dst kind) = do
dsrcs <- mapM diagnose srcs
ddst <- diagnose dst
return $ Diagnosed dsrcs ddst kind
diagnose :: FilePath -> IO DiagnosedFp
diagnose fp = do
d <- diagnoseFp fp
hash <- hashFilePath fp
return $ D fp d hash
diagnoseFp :: FilePath -> IO Diagnostics
diagnoseFp fp = do
e <- fileExist fp
if e
then do
s <- getSymbolicLinkStatus fp
if isBlockDevice s || isCharacterDevice s || isSocket s || isNamedPipe s
then return IsWeird
else do
if isSymbolicLink s
then do
point <- readSymbolicLink fp
return $ IsLinkTo point
else if isDirectory s
then return IsDirectory
else if isRegularFile s
then return IsFile
else error $ "File " ++ fp ++ " was neither a block device, a character device, a socket, a named pipe, a symbolic link, a directory or a regular file"
else do
es <- system $ unwords ["test", "-L", fp]
case es of
ExitSuccess -> do
point <- readProcess "readlink" [fp] ""
return $ IsLinkTo $ init point
ExitFailure _ -> return Nonexistent
md5 :: SB.ByteString -> HashDigest
md5 bs = H.md5 $ LB.fromStrict bs
hashFilePath :: FilePath -> IO HashDigest
hashFilePath fp = do
d <- diagnoseFp fp
case d of
IsFile -> hashFile fp
IsDirectory -> hashDirectory fp
IsLinkTo _ -> return $ md5 SB.empty
IsWeird -> return $ md5 SB.empty
Nonexistent -> return $ md5 SB.empty
hashFile :: FilePath -> IO HashDigest
hashFile fp = md5 <$> SB.readFile fp
hashDirectory :: FilePath -> IO HashDigest
hashDirectory fp = do
rawContents <- getDirectoryContents fp
let contents = map (fp </>) . filter (\f -> not $ f == "." || f == "..") $ rawContents
hashes <- mapM hashFilePath contents
let hashbs = map (SBC.pack . show) hashes
return $ md5 $ SB.concat hashbs
formatDeploymentChecks :: [(Deployment, DeploymentCheckResult)] -> String
formatDeploymentChecks dss
= if null output
then "Deployment is done already."
else unlines output ++
if all (impossibleDeployment . snd) dss
then "Deployment is impossible."
else "Deployment is possible."
where output = catMaybes $ map formatDeploymentCheck dss
formatDeploymentCheck :: (Deployment, DeploymentCheckResult) -> Maybe String
formatDeploymentCheck (_, (ReadyToDeploy is)) = Just $ "READY: " ++ formatInstruction is
formatDeploymentCheck (_, DeploymentDone) = Nothing
formatDeploymentCheck (d, ImpossibleDeployment ds)
= Just $ "IMPOSSIBLE: "
++ deployment_dst d
++ " cannot be deployed:\n"
++ unlines ds ++ "\n"
formatDeploymentCheck (d, (DirtySituation str is c))
= Just $ "DIRTY: "
++ deployment_dst d
++ "\n"
++ str
++ "planned: "
++ formatInstruction is
++ "\n"
++ "cleanup needed:\n"
++ formatCleanupInstruction c
++ "\n"
formatInstruction :: Instruction -> String
formatInstruction (Instruction src dst k) = unwords $
[ src
, kindSymbol k
, dst
]
where
kindSymbol LinkDeployment = linkKindSymbol
kindSymbol CopyDeployment = copyKindSymbol
formatCleanupInstruction :: CleanupInstruction -> String
formatCleanupInstruction (CleanFile fp) = "remove file " ++ fp
formatCleanupInstruction (CleanDirectory dir) = "remove directory " ++ dir
formatCleanupInstruction (CleanLink link) = "remove link " ++ link