{-# LANGUAGE LambdaCase #-}

{-|

Helpers for the /security-advisories/ file system.

Top-level functions that take a @FilePath@ expect the path to the
top-level directory of the /security-advisories/ repository (i.e.
it must have the @advisories/@ subdirectory).

-}
module Security.Advisories.Filesystem
  (
    dirNameAdvisories
  , dirNameReserved
  , isSecurityAdvisoriesRepo
  , getReservedIds
  , getAdvisoryIds
  , getAllocatedIds
  , greatestId
  , getGreatestId
  , forReserved
  , forAdvisory
  , listAdvisories
  ) where

import Control.Applicative (liftA2)
import Data.Bifunctor (bimap)
import Data.Foldable (fold)
import Data.Functor ((<&>))
import Data.Semigroup (Max(Max, getMax))
import Data.Traversable (for)

import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Writer.Strict (execWriterT, tell)
import qualified Data.Text.IO as T
import System.FilePath ((</>), takeBaseName)
import System.Directory (doesDirectoryExist, pathIsSymbolicLink)
import System.Directory.PathWalk
import Validation (Validation, eitherToValidation)

import Security.Advisories (Advisory, AttributeOverridePolicy (NoOverrides), OutOfBandAttributes (..), ParseAdvisoryError, emptyOutOfBandAttributes, parseAdvisory)
import Security.Advisories.Core.HsecId (HsecId, parseHsecId, placeholder)
import Security.Advisories.Git(firstAppearanceCommitDate, getAdvisoryGitInfo, lastModificationCommitDate)


dirNameAdvisories :: FilePath
dirNameAdvisories :: FilePath
dirNameAdvisories = FilePath
"advisories"

dirNameReserved :: FilePath
dirNameReserved :: FilePath
dirNameReserved = FilePath
"reserved"

-- | Check whether the directory appears to be the root of a
-- /security-advisories/ filesystem.  Only checks that the
-- @advisories@ subdirectory exists.
--
isSecurityAdvisoriesRepo :: FilePath -> IO Bool
isSecurityAdvisoriesRepo :: FilePath -> IO Bool
isSecurityAdvisoriesRepo FilePath
path =
  FilePath -> IO Bool
doesDirectoryExist (FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
dirNameAdvisories)


-- | Get a list of reserved HSEC IDs.  The order is unspecified.
--
getReservedIds :: FilePath -> IO [HsecId]
getReservedIds :: FilePath -> IO [HsecId]
getReservedIds FilePath
root =
  FilePath -> (FilePath -> HsecId -> IO [HsecId]) -> IO [HsecId]
forall (m :: * -> *) r.
(MonadIO m, Monoid r) =>
FilePath -> (FilePath -> HsecId -> m r) -> m r
forReserved FilePath
root (\FilePath
_ HsecId
hsid -> [HsecId] -> IO [HsecId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [HsecId
hsid])

-- | Get a list of used IDs (does not include reserved IDs)
-- There may be duplicates and the order is unspecified.
--
getAdvisoryIds :: FilePath -> IO [HsecId]
getAdvisoryIds :: FilePath -> IO [HsecId]
getAdvisoryIds FilePath
root =
  FilePath -> (FilePath -> HsecId -> IO [HsecId]) -> IO [HsecId]
forall (m :: * -> *) r.
(MonadIO m, Monoid r) =>
FilePath -> (FilePath -> HsecId -> m r) -> m r
forAdvisory FilePath
root (\FilePath
_ HsecId
hsid -> [HsecId] -> IO [HsecId]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [HsecId
hsid])

-- | Get all allocated IDs, including reserved IDs.
-- There may be duplicates and the order is unspecified.
--
getAllocatedIds :: FilePath -> IO [HsecId]
getAllocatedIds :: FilePath -> IO [HsecId]
getAllocatedIds FilePath
root =
  ([HsecId] -> [HsecId] -> [HsecId])
-> IO [HsecId] -> IO [HsecId] -> IO [HsecId]
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [HsecId] -> [HsecId] -> [HsecId]
forall a. Semigroup a => a -> a -> a
(<>)
    (FilePath -> IO [HsecId]
getAdvisoryIds FilePath
root)
    (FilePath -> IO [HsecId]
getReservedIds FilePath
root)

-- | Return the greatest ID in a collection of IDs.  If the
-- collection is empty, return the 'placeholder'.
--
greatestId :: (Foldable t) => t HsecId -> HsecId
greatestId :: forall (t :: * -> *). Foldable t => t HsecId -> HsecId
greatestId = Max HsecId -> HsecId
forall a. Max a -> a
getMax (Max HsecId -> HsecId)
-> (t HsecId -> Max HsecId) -> t HsecId -> HsecId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsecId -> Max HsecId -> Max HsecId)
-> Max HsecId -> t HsecId -> Max HsecId
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Max HsecId -> Max HsecId -> Max HsecId
forall a. Semigroup a => a -> a -> a
(<>) (Max HsecId -> Max HsecId -> Max HsecId)
-> (HsecId -> Max HsecId) -> HsecId -> Max HsecId -> Max HsecId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsecId -> Max HsecId
forall a. a -> Max a
Max) (HsecId -> Max HsecId
forall a. a -> Max a
Max HsecId
placeholder)

-- | Return the greatest ID in the database, including reserved IDs.
-- If there are IDs in the database, returns the 'placeholder'.
--
getGreatestId :: FilePath -> IO HsecId
getGreatestId :: FilePath -> IO HsecId
getGreatestId = ([HsecId] -> HsecId) -> IO [HsecId] -> IO HsecId
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [HsecId] -> HsecId
forall (t :: * -> *). Foldable t => t HsecId -> HsecId
greatestId (IO [HsecId] -> IO HsecId)
-> (FilePath -> IO [HsecId]) -> FilePath -> IO HsecId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO [HsecId]
getAllocatedIds


-- | Invoke a callback for each HSEC ID in the reserved
-- directory.  The results are combined monoidally.
--
forReserved
  :: (MonadIO m, Monoid r)
  => FilePath -> (FilePath -> HsecId -> m r) -> m r
forReserved :: forall (m :: * -> *) r.
(MonadIO m, Monoid r) =>
FilePath -> (FilePath -> HsecId -> m r) -> m r
forReserved FilePath
root =
  FilePath -> (FilePath -> HsecId -> m r) -> m r
forall (m :: * -> *) r.
(MonadIO m, Monoid r) =>
FilePath -> (FilePath -> HsecId -> m r) -> m r
_forFiles (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
dirNameAdvisories FilePath -> FilePath -> FilePath
</> FilePath
dirNameReserved)

-- | Invoke a callback for each HSEC ID under each of the advisory
-- subdirectories, excluding the @reserved@ directory.  The results
-- are combined monoidally.
--
-- The same ID could appear multiple times.  In particular, the callback
-- is invoked for symbolic links as well as regular files.
--
forAdvisory
  :: (MonadIO m, Monoid r)
  => FilePath -> (FilePath -> HsecId -> m r) -> m r
forAdvisory :: forall (m :: * -> *) r.
(MonadIO m, Monoid r) =>
FilePath -> (FilePath -> HsecId -> m r) -> m r
forAdvisory FilePath
root FilePath -> HsecId -> m r
go = do
  let dir :: FilePath
dir = FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
dirNameAdvisories
  [FilePath]
subdirs <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
dirNameReserved) ([FilePath] -> [FilePath]) -> m [FilePath] -> m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m [FilePath]
forall (m :: * -> *). MonadIO m => FilePath -> m [FilePath]
_getSubdirs FilePath
dir
  ([r] -> r) -> m [r] -> m r
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [r] -> r
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (m [r] -> m r) -> m [r] -> m r
forall a b. (a -> b) -> a -> b
$ [FilePath] -> (FilePath -> m r) -> m [r]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [FilePath]
subdirs ((FilePath -> m r) -> m [r]) -> (FilePath -> m r) -> m [r]
forall a b. (a -> b) -> a -> b
$ \FilePath
subdir -> FilePath -> (FilePath -> HsecId -> m r) -> m r
forall (m :: * -> *) r.
(MonadIO m, Monoid r) =>
FilePath -> (FilePath -> HsecId -> m r) -> m r
_forFiles (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
subdir) FilePath -> HsecId -> m r
go

-- | List deduplicated parsed Advisories
listAdvisories
  :: (MonadIO m)
  => FilePath -> m (Validation [ParseAdvisoryError] [Advisory])
listAdvisories :: forall (m :: * -> *).
MonadIO m =>
FilePath -> m (Validation [ParseAdvisoryError] [Advisory])
listAdvisories FilePath
root =
  FilePath
-> (FilePath
    -> HsecId -> m (Validation [ParseAdvisoryError] [Advisory]))
-> m (Validation [ParseAdvisoryError] [Advisory])
forall (m :: * -> *) r.
(MonadIO m, Monoid r) =>
FilePath -> (FilePath -> HsecId -> m r) -> m r
forAdvisory FilePath
root ((FilePath
  -> HsecId -> m (Validation [ParseAdvisoryError] [Advisory]))
 -> m (Validation [ParseAdvisoryError] [Advisory]))
-> (FilePath
    -> HsecId -> m (Validation [ParseAdvisoryError] [Advisory]))
-> m (Validation [ParseAdvisoryError] [Advisory])
forall a b. (a -> b) -> a -> b
$ \FilePath
advisoryPath HsecId
_advisoryId -> do
    Bool
isSym <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
pathIsSymbolicLink FilePath
advisoryPath
    if Bool
isSym
      then Validation [ParseAdvisoryError] [Advisory]
-> m (Validation [ParseAdvisoryError] [Advisory])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Validation [ParseAdvisoryError] [Advisory]
 -> m (Validation [ParseAdvisoryError] [Advisory]))
-> Validation [ParseAdvisoryError] [Advisory]
-> m (Validation [ParseAdvisoryError] [Advisory])
forall a b. (a -> b) -> a -> b
$ [Advisory] -> Validation [ParseAdvisoryError] [Advisory]
forall a. a -> Validation [ParseAdvisoryError] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      else do
        OutOfBandAttributes
oob <-
          IO (Either GitError AdvisoryGitInfo)
-> m (Either GitError AdvisoryGitInfo)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO (Either GitError AdvisoryGitInfo)
getAdvisoryGitInfo FilePath
advisoryPath) m (Either GitError AdvisoryGitInfo)
-> (Either GitError AdvisoryGitInfo -> OutOfBandAttributes)
-> m OutOfBandAttributes
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            Left GitError
_ -> OutOfBandAttributes
emptyOutOfBandAttributes
            Right AdvisoryGitInfo
gitInfo ->
              OutOfBandAttributes
emptyOutOfBandAttributes
                { oobPublished = Just (firstAppearanceCommitDate gitInfo),
                  oobModified = Just (lastModificationCommitDate gitInfo)
                }
        Text
fileContent <- IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
T.readFile FilePath
advisoryPath
        Validation [ParseAdvisoryError] [Advisory]
-> m (Validation [ParseAdvisoryError] [Advisory])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Validation [ParseAdvisoryError] [Advisory]
 -> m (Validation [ParseAdvisoryError] [Advisory]))
-> Validation [ParseAdvisoryError] [Advisory]
-> m (Validation [ParseAdvisoryError] [Advisory])
forall a b. (a -> b) -> a -> b
$ Either [ParseAdvisoryError] [Advisory]
-> Validation [ParseAdvisoryError] [Advisory]
forall e a. Either e a -> Validation e a
eitherToValidation (Either [ParseAdvisoryError] [Advisory]
 -> Validation [ParseAdvisoryError] [Advisory])
-> Either [ParseAdvisoryError] [Advisory]
-> Validation [ParseAdvisoryError] [Advisory]
forall a b. (a -> b) -> a -> b
$ (ParseAdvisoryError -> [ParseAdvisoryError])
-> (Advisory -> [Advisory])
-> Either ParseAdvisoryError Advisory
-> Either [ParseAdvisoryError] [Advisory]
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ParseAdvisoryError -> [ParseAdvisoryError]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return Advisory -> [Advisory]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseAdvisoryError Advisory
 -> Either [ParseAdvisoryError] [Advisory])
-> Either ParseAdvisoryError Advisory
-> Either [ParseAdvisoryError] [Advisory]
forall a b. (a -> b) -> a -> b
$ AttributeOverridePolicy
-> OutOfBandAttributes
-> Text
-> Either ParseAdvisoryError Advisory
parseAdvisory AttributeOverridePolicy
NoOverrides OutOfBandAttributes
oob Text
fileContent

-- | Get names (not paths) of subdirectories of the given directory
-- (one level).  There's no monoidal, interruptible variant of
-- @pathWalk@ so we use @WriterT@ to smuggle the result out.
--
_getSubdirs :: (MonadIO m) => FilePath -> m [FilePath]
_getSubdirs :: forall (m :: * -> *). MonadIO m => FilePath -> m [FilePath]
_getSubdirs FilePath
root =
  WriterT [FilePath] m () -> m [FilePath]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT [FilePath] m () -> m [FilePath])
-> WriterT [FilePath] m () -> m [FilePath]
forall a b. (a -> b) -> a -> b
$
    FilePath
-> Callback (WriterT [FilePath] m) WalkStatus
-> WriterT [FilePath] m ()
forall (m :: * -> *).
MonadIO m =>
FilePath -> Callback m WalkStatus -> m ()
pathWalkInterruptible FilePath
root (Callback (WriterT [FilePath] m) WalkStatus
 -> WriterT [FilePath] m ())
-> Callback (WriterT [FilePath] m) WalkStatus
-> WriterT [FilePath] m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
_ [FilePath]
subdirs [FilePath]
_ -> do
      [FilePath] -> WriterT [FilePath] m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [FilePath]
subdirs
      WalkStatus -> WriterT [FilePath] m WalkStatus
forall a. a -> WriterT [FilePath] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WalkStatus
Stop

_forFiles
  :: (MonadIO m, Monoid r)
  => FilePath  -- ^ (sub)directory name
  -> (FilePath -> HsecId -> m r)
  -> m r
_forFiles :: forall (m :: * -> *) r.
(MonadIO m, Monoid r) =>
FilePath -> (FilePath -> HsecId -> m r) -> m r
_forFiles FilePath
root FilePath -> HsecId -> m r
go =
  FilePath -> Callback m r -> m r
forall (m :: * -> *) o.
(MonadIO m, Monoid o) =>
FilePath -> Callback m o -> m o
pathWalkAccumulate FilePath
root (Callback m r -> m r) -> Callback m r -> m r
forall a b. (a -> b) -> a -> b
$ \FilePath
dir [FilePath]
_ [FilePath]
files ->
    ([r] -> r) -> m [r] -> m r
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [r] -> r
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (m [r] -> m r) -> m [r] -> m r
forall a b. (a -> b) -> a -> b
$ [FilePath] -> (FilePath -> m r) -> m [r]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [FilePath]
files ((FilePath -> m r) -> m [r]) -> (FilePath -> m r) -> m [r]
forall a b. (a -> b) -> a -> b
$ \FilePath
file ->
      case FilePath -> Maybe HsecId
parseHsecId (FilePath -> FilePath
takeBaseName FilePath
file) of
        Maybe HsecId
Nothing -> r -> m r
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
forall a. Monoid a => a
mempty
        Just HsecId
hsid -> FilePath -> HsecId -> m r
go (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file) HsecId
hsid