-- Expirations.hs: OpenPGP (RFC4880) expiration checking
-- Copyright © 2014-2015  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
module Codec.Encryption.OpenPGP.Expirations
  ( isTKTimeValid
  , getKeyExpirationTimesFromSignature
  ) where

import Control.Lens ((&), (^.), _1)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)

import Codec.Encryption.OpenPGP.Ontology (isKET)
import Codec.Encryption.OpenPGP.Types

-- this assumes that all key expiration time subpackets are valid
isTKTimeValid :: UTCTime -> TK -> Bool
isTKTimeValid :: UTCTime -> TK -> Bool
isTKTimeValid UTCTime
ct TK
key = UTCTime
ct UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
keyCreationTime Bool -> Bool -> Bool
&& UTCTime
ct UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
keyExpirationTime
  where
    keyCreationTime :: UTCTime
keyCreationTime =
      TK
key TK
-> Getting ThirtyTwoBitTimeStamp TK ThirtyTwoBitTimeStamp
-> ThirtyTwoBitTimeStamp
forall s a. s -> Getting a s a -> a
^. ((PKPayload, Maybe SKAddendum)
 -> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum))
-> TK -> Const ThirtyTwoBitTimeStamp TK
Lens' TK (PKPayload, Maybe SKAddendum)
tkKey (((PKPayload, Maybe SKAddendum)
  -> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum))
 -> TK -> Const ThirtyTwoBitTimeStamp TK)
-> ((ThirtyTwoBitTimeStamp
     -> Const ThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp)
    -> (PKPayload, Maybe SKAddendum)
    -> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum))
-> Getting ThirtyTwoBitTimeStamp TK ThirtyTwoBitTimeStamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PKPayload -> Const ThirtyTwoBitTimeStamp PKPayload)
-> (PKPayload, Maybe SKAddendum)
-> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((PKPayload -> Const ThirtyTwoBitTimeStamp PKPayload)
 -> (PKPayload, Maybe SKAddendum)
 -> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum))
-> ((ThirtyTwoBitTimeStamp
     -> Const ThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp)
    -> PKPayload -> Const ThirtyTwoBitTimeStamp PKPayload)
-> (ThirtyTwoBitTimeStamp
    -> Const ThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp)
-> (PKPayload, Maybe SKAddendum)
-> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThirtyTwoBitTimeStamp
 -> Const ThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp)
-> PKPayload -> Const ThirtyTwoBitTimeStamp PKPayload
Lens' PKPayload ThirtyTwoBitTimeStamp
timestamp ThirtyTwoBitTimeStamp
-> (ThirtyTwoBitTimeStamp -> UTCTime) -> UTCTime
forall a b. a -> (a -> b) -> b
& POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (ThirtyTwoBitTimeStamp -> POSIXTime)
-> ThirtyTwoBitTimeStamp
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThirtyTwoBitTimeStamp -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    keyExpirationTime :: UTCTime
keyExpirationTime =
      POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> ([SignaturePayload] -> POSIXTime)
-> [SignaturePayload]
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Word32 -> POSIXTime)
-> ([SignaturePayload] -> Word32)
-> [SignaturePayload]
-> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ((TK
key TK
-> Getting ThirtyTwoBitTimeStamp TK ThirtyTwoBitTimeStamp
-> ThirtyTwoBitTimeStamp
forall s a. s -> Getting a s a -> a
^. ((PKPayload, Maybe SKAddendum)
 -> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum))
-> TK -> Const ThirtyTwoBitTimeStamp TK
Lens' TK (PKPayload, Maybe SKAddendum)
tkKey (((PKPayload, Maybe SKAddendum)
  -> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum))
 -> TK -> Const ThirtyTwoBitTimeStamp TK)
-> ((ThirtyTwoBitTimeStamp
     -> Const ThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp)
    -> (PKPayload, Maybe SKAddendum)
    -> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum))
-> Getting ThirtyTwoBitTimeStamp TK ThirtyTwoBitTimeStamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PKPayload -> Const ThirtyTwoBitTimeStamp PKPayload)
-> (PKPayload, Maybe SKAddendum)
-> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((PKPayload -> Const ThirtyTwoBitTimeStamp PKPayload)
 -> (PKPayload, Maybe SKAddendum)
 -> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum))
-> ((ThirtyTwoBitTimeStamp
     -> Const ThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp)
    -> PKPayload -> Const ThirtyTwoBitTimeStamp PKPayload)
-> (ThirtyTwoBitTimeStamp
    -> Const ThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp)
-> (PKPayload, Maybe SKAddendum)
-> Const ThirtyTwoBitTimeStamp (PKPayload, Maybe SKAddendum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThirtyTwoBitTimeStamp
 -> Const ThirtyTwoBitTimeStamp ThirtyTwoBitTimeStamp)
-> PKPayload -> Const ThirtyTwoBitTimeStamp PKPayload
Lens' PKPayload ThirtyTwoBitTimeStamp
timestamp ThirtyTwoBitTimeStamp
-> (ThirtyTwoBitTimeStamp -> Word32) -> Word32
forall a b. a -> (a -> b) -> b
& ThirtyTwoBitTimeStamp -> Word32
unThirtyTwoBitTimeStamp) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+) (Word32 -> Word32)
-> ([SignaturePayload] -> Word32) -> [SignaturePayload] -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ThirtyTwoBitDuration -> Word32
unThirtyTwoBitDuration (ThirtyTwoBitDuration -> Word32)
-> ([SignaturePayload] -> ThirtyTwoBitDuration)
-> [SignaturePayload]
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      [ThirtyTwoBitDuration] -> ThirtyTwoBitDuration
forall {a}. (Bounded a, Ord a) => [a] -> a
newest ([ThirtyTwoBitDuration] -> ThirtyTwoBitDuration)
-> ([SignaturePayload] -> [ThirtyTwoBitDuration])
-> [SignaturePayload]
-> ThirtyTwoBitDuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (SignaturePayload -> [ThirtyTwoBitDuration])
-> [SignaturePayload] -> [ThirtyTwoBitDuration]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SignaturePayload -> [ThirtyTwoBitDuration]
getKeyExpirationTimesFromSignature ([SignaturePayload] -> UTCTime) -> [SignaturePayload] -> UTCTime
forall a b. (a -> b) -> a -> b
$
      (((Text, [SignaturePayload]) -> [SignaturePayload])
-> [(Text, [SignaturePayload])] -> [SignaturePayload]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, [SignaturePayload]) -> [SignaturePayload]
forall a b. (a, b) -> b
snd (TK
key TK
-> Getting
     [(Text, [SignaturePayload])] TK [(Text, [SignaturePayload])]
-> [(Text, [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [(Text, [SignaturePayload])] TK [(Text, [SignaturePayload])]
Lens' TK [(Text, [SignaturePayload])]
tkUIDs) [SignaturePayload] -> [SignaturePayload] -> [SignaturePayload]
forall a. [a] -> [a] -> [a]
++ (([UserAttrSubPacket], [SignaturePayload]) -> [SignaturePayload])
-> [([UserAttrSubPacket], [SignaturePayload])]
-> [SignaturePayload]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([UserAttrSubPacket], [SignaturePayload]) -> [SignaturePayload]
forall a b. (a, b) -> b
snd (TK
key TK
-> Getting
     [([UserAttrSubPacket], [SignaturePayload])]
     TK
     [([UserAttrSubPacket], [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
forall s a. s -> Getting a s a -> a
^. Getting
  [([UserAttrSubPacket], [SignaturePayload])]
  TK
  [([UserAttrSubPacket], [SignaturePayload])]
Lens' TK [([UserAttrSubPacket], [SignaturePayload])]
tkUAts))
    newest :: [a] -> a
newest [] = a
forall a. Bounded a => a
maxBound
    newest [a]
xs = [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
xs

getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration]
getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration]
getKeyExpirationTimesFromSignature (SigV4 SigType
_ PubKeyAlgorithm
_ HashAlgorithm
_ [SigSubPacket]
xs [SigSubPacket]
_ Word16
_ NonEmpty MPI
_) =
  (SigSubPacket -> ThirtyTwoBitDuration)
-> [SigSubPacket] -> [ThirtyTwoBitDuration]
forall a b. (a -> b) -> [a] -> [b]
map (\(SigSubPacket Bool
_ (KeyExpirationTime ThirtyTwoBitDuration
x)) -> ThirtyTwoBitDuration
x) ([SigSubPacket] -> [ThirtyTwoBitDuration])
-> [SigSubPacket] -> [ThirtyTwoBitDuration]
forall a b. (a -> b) -> a -> b
$ (SigSubPacket -> Bool) -> [SigSubPacket] -> [SigSubPacket]
forall a. (a -> Bool) -> [a] -> [a]
filter SigSubPacket -> Bool
isKET [SigSubPacket]
xs