{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}
-- | Access to things that Debian policy says should be in a valid
-- control file.  The pure functions will not throw ControlFileError
-- if they are operating on a DebianControl value returned by
-- validateDebianControl.  However, they might if they are created
-- using unsafeDebianControl.
module Debian.Control.Policy
    ( -- * Validated debian control file type
      DebianControl(unDebianControl)
    , validateDebianControl
    , unsafeDebianControl
    , parseDebianControlFromFile
    , parseDebianControl
    , ControlFileError(..)
    -- * Class of things that contain one DebianControl value
    , HasDebianControl(debianControl)
    -- * Pure functions that operate on validated control files
    , debianSourceParagraph
    , debianBinaryParagraphs
    , debianPackageParagraphs
    , debianPackageNames
    , debianSourcePackageName
    , debianBinaryPackageNames
    , debianRelations
    , debianBuildDeps
    , debianBuildDepsIndep
    ) where

import Control.Exception (Exception, throw)
import Control.Monad.Catch (MonadCatch, try)
import Data.List (intercalate)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Data.ListLike (toList)
import Debian.Control.Common (Control'(..), Paragraph'(..), Field'(..), fieldValue, ControlFunctions(parseControlFromFile, parseControl))
import Debian.Control.Text ()
import Debian.Loc (__LOC__)
import Debian.Pretty (prettyShow)
import Debian.Relation (SrcPkgName(..), BinPkgName(..), Relations, parseRelations)
import Debian.Relation.Text ()
import Language.Haskell.TH (Loc(..))
import Prelude hiding (ioError)
-- import qualified Debug.ShowPlease as Please
import Text.Parsec.Error (ParseError)

-- | Opaque (constructor not exported) type to hold a validated Debian
-- Control File
data DebianControl = DebianControl {DebianControl -> Control' Text
unDebianControl :: Control' Text}

instance Show DebianControl where
    show :: DebianControl -> String
show DebianControl
c = String
"(parseDebianControl \"\" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Pretty a => a -> String
prettyShow (DebianControl -> Control' Text
unDebianControl DebianControl
c)) forall a. [a] -> [a] -> [a]
++ String
")"

-- | Validate and return a control file in an opaque wrapper.  May
-- throw a ControlFileError.  Currently we only verify that it has a
-- Source field in the first paragraph and one or more subsequent
-- paragraphs each with a Package field, and no syntax errors in the
-- build dependencies (though they may be absent.)
validateDebianControl :: MonadCatch m => Control' Text -> m (Either ControlFileError DebianControl)
validateDebianControl :: forall (m :: * -> *).
MonadCatch m =>
Control' Text -> m (Either ControlFileError DebianControl)
validateDebianControl Control' Text
ctl =
    forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (do (SrcPkgName, [BinPkgName])
_ <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasDebianControl a => a -> (SrcPkgName, [BinPkgName])
debianPackageNames (Control' Text -> DebianControl
DebianControl Control' Text
ctl)
            Maybe Relations
_ <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasDebianControl a => a -> Maybe Relations
debianBuildDeps (Control' Text -> DebianControl
DebianControl Control' Text
ctl)
            Maybe Relations
_ <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasDebianControl a => a -> Maybe Relations
debianBuildDepsIndep (Control' Text -> DebianControl
DebianControl Control' Text
ctl)
            forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. a -> Either a b
Left (\ ()
_ -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Control' Text -> DebianControl
DebianControl Control' Text
ctl)

unsafeDebianControl :: Control' Text -> DebianControl
unsafeDebianControl :: Control' Text -> DebianControl
unsafeDebianControl = Control' Text -> DebianControl
DebianControl

parseDebianControl :: MonadCatch m => String -> Text -> m (Either ControlFileError DebianControl)
parseDebianControl :: forall (m :: * -> *).
MonadCatch m =>
String -> Text -> m (Either ControlFileError DebianControl)
parseDebianControl String
sourceName Text
s = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Loc] -> ParseError -> ControlFileError
ParseControlError [$Int
String
loc_end :: CharPos
loc_filename :: String
loc_module :: String
loc_package :: String
loc_start :: CharPos
__LOC__]) forall (m :: * -> *).
MonadCatch m =>
Control' Text -> m (Either ControlFileError DebianControl)
validateDebianControl (forall a.
ControlFunctions a =>
String -> a -> Either ParseError (Control' a)
parseControl String
sourceName Text
s)

parseDebianControlFromFile :: FilePath -> IO (Either ControlFileError DebianControl)
parseDebianControlFromFile :: String -> IO (Either ControlFileError DebianControl)
parseDebianControlFromFile String
controlPath =
  forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (forall a.
ControlFunctions a =>
String -> IO (Either ParseError (Control' a))
parseControlFromFile String
controlPath) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Loc] -> IOError -> ControlFileError
IOError [$Int
String
loc_end :: CharPos
loc_filename :: String
loc_module :: String
loc_package :: String
loc_start :: CharPos
__LOC__])
         (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Loc] -> ParseError -> ControlFileError
ParseControlError [$Int
String
loc_end :: CharPos
loc_filename :: String
loc_module :: String
loc_package :: String
loc_start :: CharPos
__LOC__]) forall (m :: * -> *).
MonadCatch m =>
Control' Text -> m (Either ControlFileError DebianControl)
validateDebianControl)

-- | Class of things that contain a validated Debian control file.
class Show a => HasDebianControl a where
    debianControl :: a -> DebianControl

instance HasDebianControl DebianControl where
    debianControl :: DebianControl -> DebianControl
debianControl = forall a. a -> a
id

class HasControl a where
    control :: a -> Control' Text

instance HasControl (Control' Text) where
    control :: Control' Text -> Control' Text
control = forall a. a -> a
id

instance HasControl DebianControl where
    control :: DebianControl -> Control' Text
control = DebianControl -> Control' Text
unDebianControl

-- | Errors that control files might throw, with source file name and
-- line number generated by template haskell.
data ControlFileError
    = NoParagraphs        {ControlFileError -> [Loc]
locs :: [Loc]}
    | NoBinaryParagraphs  {locs :: [Loc], ControlFileError -> String
ctl :: String}
    | MissingField        {locs :: [Loc], ControlFileError -> String
field :: String}
    | ParseRelationsError {locs :: [Loc], ControlFileError -> ParseError
parseError :: ParseError}
    | ParseControlError   {locs :: [Loc], parseError :: ParseError}
    | IOError             {locs :: [Loc], ControlFileError -> IOError
ioError :: IOError}
    deriving Typeable

instance Show ControlFileError where
    show :: ControlFileError -> String
show (NoParagraphs {[Loc]
locs :: [Loc]
locs :: ControlFileError -> [Loc]
..}) = forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map Loc -> String
showLoc [Loc]
locs) forall a. [a] -> [a] -> [a]
++ String
": NoParagraphs"
    show (NoBinaryParagraphs {String
[Loc]
ctl :: String
locs :: [Loc]
ctl :: ControlFileError -> String
locs :: ControlFileError -> [Loc]
..}) = forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map Loc -> String
showLoc [Loc]
locs) forall a. [a] -> [a] -> [a]
++ String
": NoBinaryParagraphs"
    show (MissingField {String
[Loc]
field :: String
locs :: [Loc]
field :: ControlFileError -> String
locs :: ControlFileError -> [Loc]
..}) = forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map Loc -> String
showLoc [Loc]
locs) forall a. [a] -> [a] -> [a]
++ String
": MissingField " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
field
    show (ParseRelationsError {[Loc]
ParseError
parseError :: ParseError
locs :: [Loc]
parseError :: ControlFileError -> ParseError
locs :: ControlFileError -> [Loc]
..}) = forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map Loc -> String
showLoc [Loc]
locs) forall a. [a] -> [a] -> [a]
++ String
": ParseRelationsError " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParseError
parseError
    show (ParseControlError {[Loc]
ParseError
parseError :: ParseError
locs :: [Loc]
parseError :: ControlFileError -> ParseError
locs :: ControlFileError -> [Loc]
..}) = forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map Loc -> String
showLoc [Loc]
locs) forall a. [a] -> [a] -> [a]
++ String
": ParseControlError " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParseError
parseError
    show (IOError {[Loc]
IOError
ioError :: IOError
locs :: [Loc]
ioError :: ControlFileError -> IOError
locs :: ControlFileError -> [Loc]
..}) = forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map Loc -> String
showLoc [Loc]
locs) forall a. [a] -> [a] -> [a]
++ String
": IOError " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOError
ioError

showLoc :: Loc -> String
showLoc :: Loc -> String
showLoc Loc
x = forall a. Show a => a -> String
show (Loc -> String
loc_filename Loc
x) forall a. [a] -> [a] -> [a]
++ String
"(line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a, b) -> a
fst (Loc -> CharPos
loc_start Loc
x)) forall a. [a] -> [a] -> [a]
++ String
", column " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a, b) -> b
snd (Loc -> CharPos
loc_start Loc
x)) forall a. [a] -> [a] -> [a]
++ String
")"

-- instance Please.Show ControlFileError where
--     show (IOError e) = "(IOError " ++ Please.show e ++ ")"
--     show (ParseRelationsError e) = "(ParseRelationsError " ++ Please.show e ++ ")"
--     show (ParseControlError e) = "(ParseControlError " ++ Please.show e ++ ")"
--     show x = show x

instance Exception ControlFileError

instance Eq ControlFileError where
    ControlFileError
_ == :: ControlFileError -> ControlFileError -> Bool
== ControlFileError
_ = Bool
False

debianPackageParagraphs :: HasDebianControl a => a -> (Paragraph' Text, [Paragraph' Text])
debianPackageParagraphs :: forall a.
HasDebianControl a =>
a -> (Paragraph' Text, [Paragraph' Text])
debianPackageParagraphs a
ctl =
    case forall a. HasDebianControl a => a -> DebianControl
removeCommentParagraphs a
ctl of
      DebianControl (Control [Paragraph' Text
_]) -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ [Loc] -> String -> ControlFileError
NoBinaryParagraphs [$Int
String
loc_end :: CharPos
loc_filename :: String
loc_module :: String
loc_package :: String
loc_start :: CharPos
__LOC__] (forall a. Show a => a -> String
show a
ctl)
      DebianControl (Control []) -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ [Loc] -> ControlFileError
NoParagraphs [$Int
String
loc_end :: CharPos
loc_filename :: String
loc_module :: String
loc_package :: String
loc_start :: CharPos
__LOC__]
      DebianControl (Control (Paragraph' Text
sourceParagraph : [Paragraph' Text]
binParagraphs)) -> (Paragraph' Text
sourceParagraph, [Paragraph' Text]
binParagraphs)

-- | Comment paragraphs are rare, but they happen.
removeCommentParagraphs :: HasDebianControl a => a -> DebianControl
removeCommentParagraphs :: forall a. HasDebianControl a => a -> DebianControl
removeCommentParagraphs a
c =
    Control' Text -> DebianControl
DebianControl (forall a. [Paragraph' a] -> Control' a
Control (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Paragraph' a -> Bool
isCommentParagraph) (forall a. Control' a -> [Paragraph' a]
unControl (DebianControl -> Control' Text
unDebianControl (forall a. HasDebianControl a => a -> DebianControl
debianControl a
c)))))
    where
      isCommentParagraph :: Paragraph' a -> Bool
isCommentParagraph (Paragraph [Field' a]
fields) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {a}. Field' a -> Bool
isCommentField [Field' a]
fields
      isCommentField :: Field' a -> Bool
isCommentField (Comment a
_) = Bool
True
      isCommentField Field' a
_ = Bool
False

debianSourceParagraph :: HasDebianControl a => a -> Paragraph' Text
debianSourceParagraph :: forall a. HasDebianControl a => a -> Paragraph' Text
debianSourceParagraph = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HasDebianControl a =>
a -> (Paragraph' Text, [Paragraph' Text])
debianPackageParagraphs

debianBinaryParagraphs :: HasDebianControl a => a -> [Paragraph' Text]
debianBinaryParagraphs :: forall a. HasDebianControl a => a -> [Paragraph' Text]
debianBinaryParagraphs = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HasDebianControl a =>
a -> (Paragraph' Text, [Paragraph' Text])
debianPackageParagraphs

debianPackageNames :: HasDebianControl a => a -> (SrcPkgName, [BinPkgName])
debianPackageNames :: forall a. HasDebianControl a => a -> (SrcPkgName, [BinPkgName])
debianPackageNames a
c =
  let (Paragraph' Text
srcParagraph, [Paragraph' Text]
binParagraphs) = forall a.
HasDebianControl a =>
a -> (Paragraph' Text, [Paragraph' Text])
debianPackageParagraphs a
c in
  (forall a. (Text -> a) -> String -> Paragraph' Text -> a
mapFieldValue (String -> SrcPkgName
SrcPkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList) String
"Source" Paragraph' Text
srcParagraph, forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Text -> a) -> String -> Paragraph' Text -> a
mapFieldValue (String -> BinPkgName
BinPkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList) String
"Package") [Paragraph' Text]
binParagraphs)

debianSourcePackageName :: HasDebianControl a => a -> SrcPkgName
debianSourcePackageName :: forall a. HasDebianControl a => a -> SrcPkgName
debianSourcePackageName = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasDebianControl a => a -> (SrcPkgName, [BinPkgName])
debianPackageNames

debianBinaryPackageNames :: HasDebianControl a => a -> [BinPkgName]
debianBinaryPackageNames :: forall a. HasDebianControl a => a -> [BinPkgName]
debianBinaryPackageNames = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasDebianControl a => a -> (SrcPkgName, [BinPkgName])
debianPackageNames

debianBuildDepsIndep :: HasDebianControl a => a -> Maybe Relations
debianBuildDepsIndep :: forall a. HasDebianControl a => a -> Maybe Relations
debianBuildDepsIndep a
ctl = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a.
HasDebianControl a =>
String -> a -> Either ControlFileError (Maybe Relations)
debianRelations String
"Build-Depends-Indep" (forall a. HasDebianControl a => a -> DebianControl
debianControl a
ctl)

debianBuildDeps :: HasDebianControl a => a -> Maybe Relations
debianBuildDeps :: forall a. HasDebianControl a => a -> Maybe Relations
debianBuildDeps a
ctl = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a.
HasDebianControl a =>
String -> a -> Either ControlFileError (Maybe Relations)
debianRelations String
"Build-Depends" (forall a. HasDebianControl a => a -> DebianControl
debianControl a
ctl)

-- | Version of fieldValue that may throw a ControlFileError.  We only
-- use this internally on fields that we already validated.
fieldValue' :: ControlFunctions text => String -> Paragraph' text -> text
fieldValue' :: forall text.
ControlFunctions text =>
String -> Paragraph' text -> text
fieldValue' String
fieldName Paragraph' text
paragraph = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ [Loc] -> String -> ControlFileError
MissingField [$Int
String
loc_end :: CharPos
loc_filename :: String
loc_module :: String
loc_package :: String
loc_start :: CharPos
__LOC__] String
fieldName) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. ControlFunctions a => String -> Paragraph' a -> Maybe a
fieldValue String
fieldName Paragraph' text
paragraph

-- | This could access fields we haven't validated, so
-- it can return an error.  Additionally, the field might
-- be absent, in which case it returns Nothing.
debianRelations :: HasDebianControl a => String -> a -> Either ControlFileError (Maybe Relations)
debianRelations :: forall a.
HasDebianControl a =>
String -> a -> Either ControlFileError (Maybe Relations)
debianRelations String
fieldName a
ctl = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right forall a. Maybe a
Nothing) (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Loc] -> ParseError -> ControlFileError
ParseRelationsError [$Int
String
loc_end :: CharPos
loc_filename :: String
loc_module :: String
loc_package :: String
loc_start :: CharPos
__LOC__]) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParseRelations a => a -> Either ParseError Relations
parseRelations) forall a b. (a -> b) -> a -> b
$ forall a. ControlFunctions a => String -> Paragraph' a -> Maybe a
fieldValue String
fieldName (forall a. HasDebianControl a => a -> Paragraph' Text
debianSourceParagraph a
ctl)

-- | Apply a function to the text from a named field in a control file paragraph.
mapFieldValue :: (Text -> a) -> String -> Paragraph' Text -> a
mapFieldValue :: forall a. (Text -> a) -> String -> Paragraph' Text -> a
mapFieldValue Text -> a
f String
fieldName Paragraph' Text
paragraph = Text -> a
f forall a b. (a -> b) -> a -> b
$ forall text.
ControlFunctions text =>
String -> Paragraph' text -> text
fieldValue' String
fieldName Paragraph' Text
paragraph