{-| Effectful functions executing shared image respository operations.
    See "B9.Repository" -}
module B9.RepositoryIO
  ( repoSearch
  , pushToRepo
  , pullFromRepo
  , pullGlob
  , Repository(..)
  , toRemoteRepository
  , FilePathGlob(..)
  )
where

import           B9.B9Config                    ( getRemoteRepos )
import           B9.B9Logging
import           B9.B9Exec
import           B9.Repository
import           Control.Eff
import           Control.Monad.IO.Class
import           Data.List
import           System.Directory
import           System.FilePath
import           System.IO.B9Extras             ( ensureDir )
import           Text.Printf                    ( printf )

data Repository
  = Cache
  | Remote String
  deriving (Eq, Ord, Read, Show)

-- | Convert a `RemoteRepo` down to a mere `Repository`
toRemoteRepository :: RemoteRepo -> Repository
toRemoteRepository = Remote . remoteRepoRepoId

-- | Find files which are in 'subDir' and match 'glob' in the repository
-- cache. NOTE: This operates on the repository cache, but does not enforce a
-- repository cache update.
repoSearch
  :: forall e
   . (CommandIO e, Member RepoCacheReader e)
  => FilePath
  -> FilePathGlob
  -> Eff e [(Repository, [FilePath])]
repoSearch subDir glob = (:) <$> localMatches <*> remoteRepoMatches
 where
  remoteRepoMatches = do
    remoteRepos <- getRemoteRepos
    mapM remoteRepoSearch remoteRepos
  localMatches :: Eff e (Repository, [FilePath])
  localMatches = do
    cache <- getRepoCache
    let dir = localRepoDir cache </> subDir
    files <- findGlob dir
    return (Cache, files)
  remoteRepoSearch :: RemoteRepo -> Eff e (Repository, [FilePath])
  remoteRepoSearch repo = do
    cache <- getRepoCache
    let dir                         = remoteRepoCacheDir cache repoId </> subDir
        (RemoteRepo repoId _ _ _ _) = repo
    files <- findGlob dir
    return (Remote repoId, files)
  findGlob :: FilePath -> Eff e [FilePath]
  findGlob dir = do
    traceL (printf "reading contents of directory '%s'" dir)
    ensureDir (dir ++ "/")
    files <- liftIO (getDirectoryContents dir)
    return ((dir </>) <$> filter (matchGlob glob) files)

-- | Push a file from the cache to a remote repository
pushToRepo :: (CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e ()
pushToRepo repo@(RemoteRepo repoId _ _ _ _) src dest = do
  dbgL (printf "PUSHING '%s' TO REPO '%s'" (takeFileName src) repoId)
  cmd (repoEnsureDirCmd repo dest)
  cmd (pushCmd repo src dest)

-- | Pull a file from a remote repository to cache
pullFromRepo :: (CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e ()
pullFromRepo repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user)) src dest
  = do
    dbgL (printf "PULLING '%s' FROM REPO '%s'" (takeFileName src) repoId)
    cmd
      (printf "rsync -rtv -e 'ssh %s' '%s@%s:%s' '%s'"
              (sshOpts repo)
              user
              host
              (rootDir </> src)
              dest
      )

-- | Push a file from the cache to a remote repository
pullGlob
  :: (CommandIO e, Member RepoCacheReader e)
  => FilePath
  -> FilePathGlob
  -> RemoteRepo
  -> Eff e ()
pullGlob subDir glob repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user))
  = do
    cache <- getRepoCache
    infoL (printf "SYNCING REPO METADATA '%s'" repoId)
    let
      c = printf
        "rsync -rtv --include '%s' --exclude '*.*' -e 'ssh %s' '%s@%s:%s/' '%s/'"
        (globToPattern glob)
        (sshOpts repo)
        user
        host
        (rootDir </> subDir)
        destDir
      destDir      = repoCacheDir </> subDir
      repoCacheDir = remoteRepoCacheDir cache repoId
    ensureDir destDir
    cmd c

-- | Express a pattern for file paths, used when searching repositories.
newtype FilePathGlob =
  FileExtension String

-- * Internals
globToPattern :: FilePathGlob -> String
globToPattern (FileExtension ext) = "*." ++ ext

-- | A predicate that is satisfied if a file path matches a glob.
matchGlob :: FilePathGlob -> FilePath -> Bool
matchGlob (FileExtension ext) = isSuffixOf ("." ++ ext)

-- | A shell command string for invoking rsync to push a path to a remote host
-- via ssh.
pushCmd :: RemoteRepo -> FilePath -> FilePath -> String
pushCmd repo@(RemoteRepo _repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user)) src dest
  = printf "rsync -rtv --inplace --ignore-existing -e 'ssh %s' '%s' '%s'"
           (sshOpts repo)
           src
           sshDest
  where sshDest = printf "%s@%s:%s/%s" user host rootDir dest :: String

-- | A shell command string for invoking rsync to create the directories for a
-- file push.
repoEnsureDirCmd :: RemoteRepo -> FilePath -> String
repoEnsureDirCmd repo@(RemoteRepo _repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user)) dest
  = printf "ssh %s %s@%s mkdir -p '%s'"
           (sshOpts repo)
           user
           host
           (rootDir </> takeDirectory dest)

sshOpts :: RemoteRepo -> String
sshOpts (RemoteRepo _repoId _rootDir (SshPrivKey key) (SshRemoteHost (_host, port)) _user)
  = unwords
    [ "-o"
    , "StrictHostKeyChecking=no"
    , "-o"
    , "UserKnownHostsFile=/dev/null"
    , "-o"
    , printf "Port=%i" port
    , "-o"
    , "IdentityFile=" ++ key
    ]