-- | Header used by all TUF types
module Hackage.Security.TUF.Header (
    HasHeader(..)
  , FileVersion(..)
  , FileExpires(..)
  , Header(..)
    -- ** Utility
  , expiresInDays
  , expiresNever
  , isExpired
  , versionInitial
  , versionIncrement
  ) where

import Prelude
import Data.Time
import Data.Typeable (Typeable)

import Hackage.Security.JSON
import Hackage.Security.Util.Lens

{-------------------------------------------------------------------------------
  TUF header
-------------------------------------------------------------------------------}

class HasHeader a where
  -- | File expiry date
  fileExpires :: Lens' a FileExpires

  -- | File version (monotonically increasing counter)
  fileVersion :: Lens' a FileVersion

-- | File version
--
-- The file version is a flat integer which must monotonically increase on
-- every file update.
--
-- 'Show' and 'Read' instance are defined in terms of the underlying 'Int'
-- (this is used for example by Hackage during the backup process).
newtype FileVersion = FileVersion Int54
  deriving (FileVersion -> FileVersion -> Bool
(FileVersion -> FileVersion -> Bool)
-> (FileVersion -> FileVersion -> Bool) -> Eq FileVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileVersion -> FileVersion -> Bool
== :: FileVersion -> FileVersion -> Bool
$c/= :: FileVersion -> FileVersion -> Bool
/= :: FileVersion -> FileVersion -> Bool
Eq, Eq FileVersion
Eq FileVersion =>
(FileVersion -> FileVersion -> Ordering)
-> (FileVersion -> FileVersion -> Bool)
-> (FileVersion -> FileVersion -> Bool)
-> (FileVersion -> FileVersion -> Bool)
-> (FileVersion -> FileVersion -> Bool)
-> (FileVersion -> FileVersion -> FileVersion)
-> (FileVersion -> FileVersion -> FileVersion)
-> Ord FileVersion
FileVersion -> FileVersion -> Bool
FileVersion -> FileVersion -> Ordering
FileVersion -> FileVersion -> FileVersion
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FileVersion -> FileVersion -> Ordering
compare :: FileVersion -> FileVersion -> Ordering
$c< :: FileVersion -> FileVersion -> Bool
< :: FileVersion -> FileVersion -> Bool
$c<= :: FileVersion -> FileVersion -> Bool
<= :: FileVersion -> FileVersion -> Bool
$c> :: FileVersion -> FileVersion -> Bool
> :: FileVersion -> FileVersion -> Bool
$c>= :: FileVersion -> FileVersion -> Bool
>= :: FileVersion -> FileVersion -> Bool
$cmax :: FileVersion -> FileVersion -> FileVersion
max :: FileVersion -> FileVersion -> FileVersion
$cmin :: FileVersion -> FileVersion -> FileVersion
min :: FileVersion -> FileVersion -> FileVersion
Ord, Typeable)

instance Show FileVersion where
  show :: FileVersion -> String
show (FileVersion Int54
v) = Int54 -> String
forall a. Show a => a -> String
show Int54
v

instance Read FileVersion where
  readsPrec :: Int -> ReadS FileVersion
readsPrec Int
p = ((Int54, String) -> (FileVersion, String))
-> [(Int54, String)] -> [(FileVersion, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int54
v, String
xs) -> (Int54 -> FileVersion
FileVersion Int54
v, String
xs)) ([(Int54, String)] -> [(FileVersion, String)])
-> (String -> [(Int54, String)]) -> ReadS FileVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> [(Int54, String)]
forall a. Read a => Int -> ReadS a
readsPrec Int
p

-- | File expiry date
--
-- A 'Nothing' value here means no expiry. That makes it possible to set some
-- files to never expire. (Note that not having the Maybe in the type here still
-- allows that, because you could set an expiry date 2000 years into the future.
-- By having the Maybe here we avoid the _need_ for such encoding issues.)
newtype FileExpires = FileExpires (Maybe UTCTime)
  deriving (FileExpires -> FileExpires -> Bool
(FileExpires -> FileExpires -> Bool)
-> (FileExpires -> FileExpires -> Bool) -> Eq FileExpires
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileExpires -> FileExpires -> Bool
== :: FileExpires -> FileExpires -> Bool
$c/= :: FileExpires -> FileExpires -> Bool
/= :: FileExpires -> FileExpires -> Bool
Eq, Eq FileExpires
Eq FileExpires =>
(FileExpires -> FileExpires -> Ordering)
-> (FileExpires -> FileExpires -> Bool)
-> (FileExpires -> FileExpires -> Bool)
-> (FileExpires -> FileExpires -> Bool)
-> (FileExpires -> FileExpires -> Bool)
-> (FileExpires -> FileExpires -> FileExpires)
-> (FileExpires -> FileExpires -> FileExpires)
-> Ord FileExpires
FileExpires -> FileExpires -> Bool
FileExpires -> FileExpires -> Ordering
FileExpires -> FileExpires -> FileExpires
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FileExpires -> FileExpires -> Ordering
compare :: FileExpires -> FileExpires -> Ordering
$c< :: FileExpires -> FileExpires -> Bool
< :: FileExpires -> FileExpires -> Bool
$c<= :: FileExpires -> FileExpires -> Bool
<= :: FileExpires -> FileExpires -> Bool
$c> :: FileExpires -> FileExpires -> Bool
> :: FileExpires -> FileExpires -> Bool
$c>= :: FileExpires -> FileExpires -> Bool
>= :: FileExpires -> FileExpires -> Bool
$cmax :: FileExpires -> FileExpires -> FileExpires
max :: FileExpires -> FileExpires -> FileExpires
$cmin :: FileExpires -> FileExpires -> FileExpires
min :: FileExpires -> FileExpires -> FileExpires
Ord, Int -> FileExpires -> ShowS
[FileExpires] -> ShowS
FileExpires -> String
(Int -> FileExpires -> ShowS)
-> (FileExpires -> String)
-> ([FileExpires] -> ShowS)
-> Show FileExpires
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileExpires -> ShowS
showsPrec :: Int -> FileExpires -> ShowS
$cshow :: FileExpires -> String
show :: FileExpires -> String
$cshowList :: [FileExpires] -> ShowS
showList :: [FileExpires] -> ShowS
Show, Typeable)

-- | Occasionally it is useful to read only a header from a file.
--
-- 'HeaderOnly' intentionally only has a 'FromJSON' instance (no 'ToJSON').
data Header = Header {
    Header -> FileExpires
headerExpires :: FileExpires
  , Header -> FileVersion
headerVersion :: FileVersion
  }

instance HasHeader Header where
  fileExpires :: Lens' Header FileExpires
fileExpires FileExpires -> f FileExpires
f Header
x = (\FileExpires
y -> Header
x { headerExpires = y }) (FileExpires -> Header) -> f FileExpires -> f Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FileExpires -> f FileExpires
f (Header -> FileExpires
headerExpires Header
x)
  fileVersion :: Lens' Header FileVersion
fileVersion FileVersion -> f FileVersion
f Header
x = (\FileVersion
y -> Header
x { headerVersion = y }) (FileVersion -> Header) -> f FileVersion -> f Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FileVersion -> f FileVersion
f (Header -> FileVersion
headerVersion Header
x)

{-------------------------------------------------------------------------------
  Utility
-------------------------------------------------------------------------------}

expiresNever :: FileExpires
expiresNever :: FileExpires
expiresNever = Maybe UTCTime -> FileExpires
FileExpires Maybe UTCTime
forall a. Maybe a
Nothing

expiresInDays :: UTCTime -> Integer -> FileExpires
expiresInDays :: UTCTime -> Integer -> FileExpires
expiresInDays UTCTime
now Integer
n =
    Maybe UTCTime -> FileExpires
FileExpires (Maybe UTCTime -> FileExpires)
-> (UTCTime -> Maybe UTCTime) -> UTCTime -> FileExpires
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> FileExpires) -> UTCTime -> FileExpires
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger Integer
n NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
oneDay) UTCTime
now

isExpired :: UTCTime -> FileExpires -> Bool
isExpired :: UTCTime -> FileExpires -> Bool
isExpired UTCTime
_   (FileExpires Maybe UTCTime
Nothing)  = Bool
False
isExpired UTCTime
now (FileExpires (Just UTCTime
e)) = UTCTime
e UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now

versionInitial :: FileVersion
versionInitial :: FileVersion
versionInitial = Int54 -> FileVersion
FileVersion Int54
1

versionIncrement :: FileVersion -> FileVersion
versionIncrement :: FileVersion -> FileVersion
versionIncrement (FileVersion Int54
i) = Int54 -> FileVersion
FileVersion (Int54
i Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
+ Int54
1)

{-------------------------------------------------------------------------------
  JSON
-------------------------------------------------------------------------------}

instance Monad m => ToJSON m FileVersion where
  toJSON :: FileVersion -> m JSValue
toJSON (FileVersion Int54
i) = Int54 -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON Int54
i

instance Monad m => ToJSON m FileExpires where
  toJSON :: FileExpires -> m JSValue
toJSON (FileExpires (Just UTCTime
e)) = UTCTime -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON UTCTime
e
  toJSON (FileExpires Maybe UTCTime
Nothing)  = JSValue -> m JSValue
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
JSNull

instance ReportSchemaErrors m => FromJSON m FileVersion where
  fromJSON :: JSValue -> m FileVersion
fromJSON JSValue
enc = Int54 -> FileVersion
FileVersion (Int54 -> FileVersion) -> m Int54 -> m FileVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> m Int54
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc

instance ReportSchemaErrors m => FromJSON m FileExpires where
  fromJSON :: JSValue -> m FileExpires
fromJSON JSValue
JSNull = FileExpires -> m FileExpires
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileExpires -> m FileExpires) -> FileExpires -> m FileExpires
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> FileExpires
FileExpires Maybe UTCTime
forall a. Maybe a
Nothing
  fromJSON JSValue
enc    = Maybe UTCTime -> FileExpires
FileExpires (Maybe UTCTime -> FileExpires)
-> (UTCTime -> Maybe UTCTime) -> UTCTime -> FileExpires
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> FileExpires) -> m UTCTime -> m FileExpires
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> m UTCTime
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc

instance ReportSchemaErrors m => FromJSON m Header where
  fromJSON :: JSValue -> m Header
fromJSON JSValue
enc = do
    FileExpires
headerExpires <- JSValue -> String -> m FileExpires
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"expires"
    FileVersion
headerVersion <- JSValue -> String -> m FileVersion
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"version"
    Header -> m Header
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Header{FileExpires
FileVersion
headerExpires :: FileExpires
headerVersion :: FileVersion
headerExpires :: FileExpires
headerVersion :: FileVersion
..}

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

oneDay :: NominalDiffTime
oneDay :: NominalDiffTime
oneDay = NominalDiffTime
24 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60