module Network.AWS.CloudFront.SignedCookies.Policy
  (
  -- * Defining a policy
    Policy (..)
  , simplePolicy

  -- * Components of a policy
  , Resource (..)
  , StartTime (..)
  , EndTime (..)
  , Lifespan (..)
  , IpAddress (..)

  -- * JSON representation
  , policyJSON
  , jsonTextPolicy
  , jsonValPolicy

  ) where

import Network.AWS.CloudFront.SignedCookies.Types (ByteString, EndTime (..), IpAddress (..), Lifespan (..), POSIXTime, Policy (..), Resource (..), StartTime (..), Text)

-- aeson
import Data.Aeson (toJSON, (.=))
import qualified Data.Aeson as A (Value, eitherDecode', encode, object)
import qualified Data.Aeson.Types as A (Pair)

-- base
import Control.Monad ((>=>))

-- bytestring
import qualified Data.ByteString.Lazy as LBS

-- lens
import Control.Lens ((^?))

-- lens-aeson
import Data.Aeson.Lens (AsNumber (..), AsValue (..), key, nth)

-- text
import qualified Data.Text.Encoding as Text

-- time
import Data.Time.Clock.POSIX (getPOSIXTime)

-- vector

{- |

Encode a 'Policy' as JSON, with no whitespace, as AWS requires.

Excerpt from [Setting Signed Cookies Using a Custom Policy](https://docs.aws.amazon.com/AmazonCloudFront/latest/DeveloperGuide/private-content-setting-signed-cookie-custom-policy.html):

* "Remove all whitespace (including tabs and newline characters) from the policy statement."

-}

policyJSON :: Policy -> ByteString
policyJSON :: Policy -> ByteString
policyJSON =
  ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Policy -> ByteString) -> Policy -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> ByteString) -> (Policy -> Value) -> Policy -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Policy -> Value
policyValue

policyValue :: Policy -> A.Value
policyValue :: Policy -> Value
policyValue Policy
policy = [Pair] -> Value
A.object [ Key
"Statement" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Value
statement ]
  where
    statement :: Value
statement = forall a. ToJSON a => a -> Value
toJSON @[A.Value]
      [ [Pair] -> Value
A.object
        [ Key
"Resource" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Policy -> Value
resourceValue Policy
policy
        , Key
"Condition" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Policy -> Value
conditionValue Policy
policy
        ]
      ]

resourceValue :: Policy -> A.Value
resourceValue :: Policy -> Value
resourceValue (Policy (Resource Text
x) StartTime
_ EndTime
_ IpAddress
_) = forall a. ToJSON a => a -> Value
toJSON @Text Text
x

conditionValue :: Policy -> A.Value
conditionValue :: Policy -> Value
conditionValue (Policy Resource
_ StartTime
start EndTime
end IpAddress
ip) =
  [Pair] -> Value
A.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair]
startCondition [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
endCondition [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
ipCondition
  where

    [Pair]
startCondition :: [A.Pair] =
      case StartTime
start of
        StartTime
StartImmediately -> []
        StartTime POSIXTime
x -> [Key
"DateGreaterThan" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= POSIXTime -> Value
posixTimeValue POSIXTime
x]

    [Pair]
endCondition :: [A.Pair] =
      case EndTime
end of
        EndTime POSIXTime
x -> [Key
"DateLessThan" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= POSIXTime -> Value
posixTimeValue POSIXTime
x]

    [Pair]
ipCondition :: [A.Pair] =
      case IpAddress
ip of
        IpAddress
AnyIp -> []
        IpAddress Text
x -> [Key
"IpAddress" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
sourceIpValue Text
x]

posixTimeValue :: POSIXTime -> A.Value
posixTimeValue :: POSIXTime -> Value
posixTimeValue POSIXTime
x = [Pair] -> Value
A.object [Key
"AWS:EpochTime" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= forall a. ToJSON a => a -> Value
toJSON @Integer (POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round POSIXTime
x) ]

sourceIpValue :: Text -> A.Value
sourceIpValue :: Text -> Value
sourceIpValue Text
x = [Pair] -> Value
A.object [Key
"AWS:SourceIp" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= forall a. ToJSON a => a -> Value
toJSON @Text Text
x]

jsonTextPolicy :: Text -> Either String Policy
jsonTextPolicy :: Text -> Either String Policy
jsonTextPolicy =
  (ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode' (ByteString -> Either String Value)
-> (Text -> ByteString) -> Text -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8) (Text -> Either String Value)
-> (Value -> Either String Policy) -> Text -> Either String Policy
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
  Value -> Either String Policy
jsonValPolicy

jsonValPolicy :: A.Value -> Either String Policy
jsonValPolicy :: Value -> Either String Policy
jsonValPolicy Value
val =
  Resource -> StartTime -> EndTime -> IpAddress -> Policy
Policy
    (Resource -> StartTime -> EndTime -> IpAddress -> Policy)
-> Either String Resource
-> Either String (StartTime -> EndTime -> IpAddress -> Policy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String Resource
jsonResource  Value
val
    Either String (StartTime -> EndTime -> IpAddress -> Policy)
-> Either String StartTime
-> Either String (EndTime -> IpAddress -> Policy)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either String StartTime
jsonStart     Value
val
    Either String (EndTime -> IpAddress -> Policy)
-> Either String EndTime -> Either String (IpAddress -> Policy)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either String EndTime
jsonEnd       Value
val
    Either String (IpAddress -> Policy)
-> Either String IpAddress -> Either String Policy
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either String IpAddress
jsonIpAddress Value
val

jsonResource :: A.Value -> Either String Resource
jsonResource :: Value -> Either String Resource
jsonResource Value
val =
  Either String Resource
-> (Resource -> Either String Resource)
-> Maybe Resource
-> Either String Resource
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Resource
forall a b. a -> Either a b
Left String
"Missing \"Resource\"") Resource -> Either String Resource
forall a b. b -> Either a b
Right (Maybe Resource -> Either String Resource)
-> Maybe Resource -> Either String Resource
forall a b. (a -> b) -> a -> b
$
    (Text -> Resource) -> Maybe Text -> Maybe Resource
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Resource
Resource
      (Value
val Value -> Getting (First Text) Value Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Statement"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Resource"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String)

jsonStart :: A.Value -> Either String StartTime
jsonStart :: Value -> Either String StartTime
jsonStart Value
val =
  StartTime -> Either String StartTime
forall a b. b -> Either a b
Right (StartTime -> Either String StartTime)
-> StartTime -> Either String StartTime
forall a b. (a -> b) -> a -> b
$
    StartTime -> (Integer -> StartTime) -> Maybe Integer -> StartTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StartTime
StartImmediately (POSIXTime -> StartTime
StartTime (POSIXTime -> StartTime)
-> (Integer -> POSIXTime) -> Integer -> StartTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> POSIXTime
forall a. Num a => Integer -> a
fromInteger)
      (Value
val Value -> Getting (First Integer) Value Integer -> Maybe Integer
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Statement"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Condition"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"DateGreaterThan"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"AWS:EpochTime"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Integer) Value Integer
forall t. AsNumber t => Prism' t Integer
Prism' Value Integer
_Integer)

jsonEnd :: A.Value -> Either String EndTime
jsonEnd :: Value -> Either String EndTime
jsonEnd Value
val =
  Either String EndTime
-> (EndTime -> Either String EndTime)
-> Maybe EndTime
-> Either String EndTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String EndTime
forall a b. a -> Either a b
Left String
"Missing \"DateLessThan\"") EndTime -> Either String EndTime
forall a b. b -> Either a b
Right (Maybe EndTime -> Either String EndTime)
-> Maybe EndTime -> Either String EndTime
forall a b. (a -> b) -> a -> b
$
    (Integer -> EndTime) -> Maybe Integer -> Maybe EndTime
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (POSIXTime -> EndTime
EndTime (POSIXTime -> EndTime)
-> (Integer -> POSIXTime) -> Integer -> EndTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> POSIXTime
forall a. Num a => Integer -> a
fromInteger)
      (Value
val Value -> Getting (First Integer) Value Integer -> Maybe Integer
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Statement"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Condition"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"DateLessThan"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"AWS:EpochTime"
            ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Integer) Value Integer
forall t. AsNumber t => Prism' t Integer
Prism' Value Integer
_Integer)

jsonIpAddress :: A.Value -> Either String IpAddress
jsonIpAddress :: Value -> Either String IpAddress
jsonIpAddress Value
val =
  IpAddress -> Either String IpAddress
forall a b. b -> Either a b
Right (IpAddress -> Either String IpAddress)
-> IpAddress -> Either String IpAddress
forall a b. (a -> b) -> a -> b
$
    IpAddress -> (Text -> IpAddress) -> Maybe Text -> IpAddress
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IpAddress
AnyIp Text -> IpAddress
IpAddress
      (Value
val Value -> Getting (First Text) Value Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Statement"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Traversal' Value Value
forall t. AsValue t => Int -> Traversal' t Value
nth Int
0
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Condition"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"IpAddress"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"AWS:SourceIp"
            ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String)

{- |

This function provides one convenient way to construct a simple 'Policy'.

For the full set of policy options, use the 'Policy' constructor directly.

-}

simplePolicy
  :: Resource   -- ^ URL that the policy will grant access to,
                --   optionally containing asterisks for wildcards
  -> Lifespan   -- ^ How long from now the credentials expire
  -> IO Policy

simplePolicy :: Resource -> Lifespan -> IO Policy
simplePolicy Resource
res Lifespan
life = do

  POSIXTime
now :: POSIXTime <- IO POSIXTime
getPOSIXTime

  let end :: EndTime
end = case Lifespan
life of Lifespan POSIXTime
x -> POSIXTime -> EndTime
EndTime (POSIXTime
now POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
x)

  Policy -> IO Policy
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Policy
      { policyResource :: Resource
policyResource  = Resource
res
      , policyEnd :: EndTime
policyEnd       = EndTime
end
      , policyStart :: StartTime
policyStart     = StartTime
StartImmediately
      , policyIpAddress :: IpAddress
policyIpAddress = IpAddress
AnyIp
      }