{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveFoldable       #-}
{-# LANGUAGE DeriveFunctor        #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE UndecidableInstances #-}

module StrongSwan.SQL.Types where

import Control.Exception        (Exception, throw)
import Data.ASN1.Types          (ASN1)
import Data.ByteString.Char8    (ByteString, pack, unpack)
import Data.Default             (Default(..))
import Data.IP                  (IP(..), IPv4, IPv6, fromIPv4, toIPv4, fromIPv6b, toIPv6b)
import Data.Text                (Text)
import Data.Typeable            (Typeable)
import Data.Word                (Word8, Word16, Word32)
import Network.Socket           (PortNumber)

import qualified Data.ByteString     as B
import qualified Data.Text           as T
import qualified Database.MySQL.Base as SQL

data Error = UnknownCharacterEncoding Int
           | UnknownSAMode Int
           | UnknownSAAction Int
           | UnknownCertPolicy Int
           | UnknownAuthMethod Int
           | UnknownEAPType Int
           | UnknownTrafficSelectorType Int
           | UnknownTrafficSelectorKind Int
           | UnknownSharedSecretType Int
           | InvalidValueForType String String
           | SQLValuesMismatch String String
           | NotFound Text
           | MultipleResults Text String
           | FailedOperation Text
           deriving (Typeable, Show)

instance Exception Error

data Result a = Result {
                  lastModifiedKey :: a,
                  response :: SQL.OK
                }

data MySQLCharacterEncoding = UTF8MB4 -- ^ utf8mb4_unicode_ci
                            | UTF8    -- ^ utf8_general_ci
                            | UCS2    -- ^ ucs2_general_ci
                            | UTF16   -- ^ utf16_general_ci
                            | UTF16LE -- ^ utf16le_general_ci
                            | UTF32   -- ^ utf32_general_ci
                            deriving Show

instance Enum MySQLCharacterEncoding where
  fromEnum UTF8MB4 = 224
  fromEnum UTF8    = 33
  fromEnum UCS2    = 35
  fromEnum UTF16   = 54
  fromEnum UTF16LE = 56
  fromEnum UTF32   = 60
  toEnum 224 = UTF8MB4
  toEnum 33  = UTF8
  toEnum 35  = UCS2
  toEnum 54  = UTF16
  toEnum 56  = UTF16LE
  toEnum 60  = UTF32
  toEnum x   = throw $ UnknownCharacterEncoding x

data Identity = AnyID (Maybe Int)                 -- Matches any ID (/%any/)
              | IPv4AddrID (Maybe Int) IPv4       -- IPv4 Address
              | NameID (Maybe Int) Text           -- Fully qualified Domain Name
              | EmailID (Maybe Int) Text Text -- ^ RFC 822 Email Address /mailbox/@/domain/
              | IPv6AddrID (Maybe Int) IPv6       -- IPv6 Address
              | ASN1ID (Maybe Int) [ASN1]         -- DER encoded ASN.1 distinguished name
              | OpaqueID (Maybe Int) ByteString   -- Opaque octet string as ID
              deriving (Eq)

instance Show Identity where
    show (AnyID iD)           = "%any (" ++ show iD ++ ")"
    show (IPv4AddrID iD ipv4) = "ipv4: " ++ show ipv4 ++ " (" ++ show iD ++ ")"
    show (NameID iD name)     = "fqdn: " ++ T.unpack name ++ " (" ++ show iD ++ ")"
    show (EmailID iD mbox domain) = "email: " ++ T.unpack mbox ++ '@':T.unpack domain ++ " (" ++ show iD ++ ")"
    show (IPv6AddrID iD ipv6) = "ipv6: " ++ show ipv6 ++ " (" ++ show iD ++ ")"
    show (ASN1ID iD asn1s)    = "asn1: " ++ show asn1s ++ " (" ++ show iD ++ ")"
    show (OpaqueID iD bytes)  = "opaque:" ++ unpack bytes ++ " (" ++ show iD ++ ")"

getIdentityId :: Identity -> Maybe Int
getIdentityId (AnyID iD)        = iD
getIdentityId (IPv4AddrID iD _) = iD
getIdentityId (NameID iD _)     = iD
getIdentityId (EmailID iD _ _)  = iD
getIdentityId (IPv6AddrID iD _) = iD
getIdentityId (ASN1ID iD _)     = iD
getIdentityId (OpaqueID iD _)   = iD

setIdentityId :: Identity -> Int -> Identity
setIdentityId (AnyID _)        iD = AnyID (Just iD)
setIdentityId (IPv4AddrID _ x) iD = IPv4AddrID (Just iD) x
setIdentityId (NameID _ x)     iD = NameID (Just iD) x
setIdentityId (EmailID _ x y)  iD = EmailID (Just iD) x y
setIdentityId (IPv6AddrID _ x) iD = IPv6AddrID (Just iD) x
setIdentityId (ASN1ID _ x)     iD = ASN1ID (Just iD) x
setIdentityId (OpaqueID _ x)   iD = OpaqueID (Just iD) x

instance Default Identity where
    def = AnyID Nothing

data Value (a :: k -> SQL.MySQLValue) where
    TinyInt   :: Word8      -> Value 'SQL.MySQLInt8U
    SmallInt  :: Word16     -> Value 'SQL.MySQLInt16U
    IntWord32 :: Word32     -> Value 'SQL.MySQLInt32U
    VarBinary :: ByteString -> Value 'SQL.MySQLBytes
    VarChar   :: Text       -> Value 'SQL.MySQLText
    NullChar  :: Value 'SQL.MySQLText

class TinyInt a where
    toTinyInt   :: a -> Value 'SQL.MySQLInt8U
    fromTinyInt :: Value 'SQL.MySQLInt8U -> a

instance TinyInt Bool where
    toTinyInt False = TinyInt 0
    toTinyInt True  = TinyInt 1

    fromTinyInt (TinyInt 0) = False
    fromTinyInt (TinyInt _) = True

instance TinyInt Word8 where
    toTinyInt = TinyInt
    fromTinyInt (TinyInt x) = x

toSQLEnum :: (Enum a) => a -> Value 'SQL.MySQLInt8U
toSQLEnum = TinyInt . fromIntegral . fromEnum

fromSQLEnum :: (Enum a) => Value 'SQL.MySQLInt8U -> a
fromSQLEnum (TinyInt x) = toEnum $ fromIntegral x

instance TinyInt SAAction where
  toTinyInt = toSQLEnum
  fromTinyInt = fromSQLEnum

instance TinyInt SAMode where
  toTinyInt = toSQLEnum
  fromTinyInt = fromSQLEnum

instance TinyInt CertPolicy where
  toTinyInt = toSQLEnum
  fromTinyInt = fromSQLEnum

instance TinyInt AuthMethod where
  toTinyInt = toSQLEnum
  fromTinyInt = fromSQLEnum

instance TinyInt EAPType where
  toTinyInt = toSQLEnum
  fromTinyInt = fromSQLEnum

instance TinyInt TrafficSelectorType where
  toTinyInt = toSQLEnum
  fromTinyInt = fromSQLEnum

instance TinyInt TrafficSelectorKind where
  toTinyInt = toSQLEnum
  fromTinyInt = fromSQLEnum

instance TinyInt SharedSecretType where
  toTinyInt = toSQLEnum
  fromTinyInt = fromSQLEnum

class SmallInt a where
    toSmallInt   :: a -> Value 'SQL.MySQLInt16U
    fromSmallInt :: Value 'SQL.MySQLInt16U -> a

instance SmallInt Word16 where
    toSmallInt = SmallInt
    fromSmallInt (SmallInt x) = x

instance SmallInt PortNumber where
    toSmallInt = SmallInt . fromIntegral
    fromSmallInt (SmallInt x) = fromIntegral x

class IntWord32 a where
    toInt :: a -> Value 'SQL.MySQLInt32U
    fromInt :: Value 'SQL.MySQLInt32U -> a

instance (Integral n) => IntWord32 n where
    toInt = IntWord32 . fromIntegral
    fromInt (IntWord32 x) = fromIntegral x

class VarChar a where
    toVarChar :: Maybe a -> Value 'SQL.MySQLText
    fromVarChar :: Value 'SQL.MySQLText -> Maybe a

instance VarChar Text where
    toVarChar Nothing          = NullChar
    toVarChar (Just text)      = VarChar text
    fromVarChar (VarChar text) = Just text
    fromVarChar NullChar       = Nothing

class VarBinary a where
    toVarBinary   :: a -> Value 'SQL.MySQLBytes
    fromVarBinary :: Value 'SQL.MySQLBytes -> a

instance VarBinary String where
    toVarBinary = VarBinary . pack
    fromVarBinary (VarBinary bytes) = unpack bytes

instance VarBinary Text where
    toVarBinary = VarBinary . pack . T.unpack
    fromVarBinary (VarBinary bytes) = T.pack $ unpack bytes

instance VarBinary ByteString where
    toVarBinary = VarBinary
    fromVarBinary (VarBinary bytes) = bytes

instance VarBinary IPv4 where
    toVarBinary = VarBinary . B.pack . fmap fromIntegral . fromIPv4
    fromVarBinary (VarBinary bytes) = toIPv4 . fmap fromIntegral $ B.unpack bytes

instance VarBinary IPv6 where
    toVarBinary = VarBinary . B.pack . fmap fromIntegral . fromIPv6b
    fromVarBinary (VarBinary bytes) = toIPv6b . fmap fromIntegral $ B.unpack bytes

instance VarBinary IP where
    toVarBinary (IPv4 addr) = toVarBinary addr
    toVarBinary (IPv6 addr) = toVarBinary addr
    fromVarBinary value@(VarBinary bytes)
      | B.length bytes == 4 = IPv4 $ fromVarBinary value
      | otherwise           = IPv6 $ fromVarBinary value

data SAMode = Transport
            | Tunnel
            | Beet
            | Pass
            | Drop
            deriving (Eq, Show)

instance Enum SAMode where
    fromEnum Transport = 1
    fromEnum Tunnel    = 2
    fromEnum Beet      = 3
    fromEnum Pass      = 4
    fromEnum Drop      = 5
    toEnum 1 = Transport
    toEnum 2 = Tunnel
    toEnum 3 = Beet
    toEnum 4 = Pass
    toEnum 5 = Drop
    toEnum x = throw $ UnknownSAMode x

data SAAction = None
              | Route
              | Restart
              deriving (Eq, Show)

instance Enum SAAction where
    fromEnum None     = 0
    fromEnum Route    = 1
    fromEnum Restart  = 2
    toEnum 0 = None
    toEnum 1 = Route
    toEnum 2 = Restart
    toEnum x = throw $ UnknownSAAction x

data CertPolicy = AlwaysSend
                | SendIfAsked
                | NeverSend
                deriving (Eq, Show)

instance Enum CertPolicy where
    fromEnum AlwaysSend  = 0
    fromEnum SendIfAsked = 1
    fromEnum NeverSend   = 2
    toEnum 0 = AlwaysSend
    toEnum 1 = SendIfAsked
    toEnum 2 = NeverSend
    toEnum x = throw $ UnknownCertPolicy x

data AuthMethod = AnyAuth
                | PubKey
                | PSK
                | EAP
                | XAUTH
                deriving (Eq, Show)

instance Enum AuthMethod where
    fromEnum AnyAuth = 0
    fromEnum PubKey  = 1
    fromEnum PSK     = 2
    fromEnum EAP     = 3
    fromEnum XAUTH   = 4

    toEnum 0 = AnyAuth
    toEnum 1 = PubKey
    toEnum 2 = PSK
    toEnum 3 = EAP
    toEnum 4 = XAUTH
    toEnum x = throw $ UnknownAuthMethod x

data EAPType = EAPUnspecified
             | EAPMD5
             | EAPGTC
             | EAPTLS
             | EAPSIM
             | EAPTTLS
             | EAPAKA
             | EAPMSCHAPV2
             | EAPTNC
             | EAPRADIUS
             deriving (Eq, Show)

instance Enum EAPType where
      fromEnum EAPUnspecified = 0
      fromEnum EAPMD5         = 4
      fromEnum EAPGTC         = 6
      fromEnum EAPTLS         = 13
      fromEnum EAPSIM         = 18
      fromEnum EAPTTLS        = 21
      fromEnum EAPAKA         = 23
      fromEnum EAPMSCHAPV2    = 26
      fromEnum EAPTNC         = 38
      fromEnum EAPRADIUS      = 253

      toEnum 0   = EAPUnspecified
      toEnum 4   = EAPMD5
      toEnum 6   = EAPGTC
      toEnum 13  = EAPTLS
      toEnum 18  = EAPSIM
      toEnum 21  = EAPTTLS
      toEnum 23  = EAPAKA
      toEnum 26  = EAPMSCHAPV2
      toEnum 38  = EAPTNC
      toEnum 253 = EAPRADIUS
      toEnum x   = throw $ UnknownEAPType x

data TrafficSelectorType = IPv4AddrRange
                         | IPv6AddrRange
                         deriving (Eq, Show)

instance Enum TrafficSelectorType where
      fromEnum IPv4AddrRange = 7
      fromEnum IPv6AddrRange = 8
      toEnum 7 = IPv4AddrRange
      toEnum 8 = IPv6AddrRange
      toEnum x = throw $ UnknownTrafficSelectorType x

data TrafficSelectorKind = LocalTS
                         | RemoteTS
                         | LocalDynamicTS
                         | RemoteDynamicTS
                         deriving (Eq, Show)

instance Enum TrafficSelectorKind where
      fromEnum LocalTS         = 0
      fromEnum RemoteTS        = 1
      fromEnum LocalDynamicTS  = 2
      fromEnum RemoteDynamicTS = 3
      toEnum 0 = LocalTS
      toEnum 1 = RemoteTS
      toEnum 2 = LocalDynamicTS
      toEnum 3 = RemoteDynamicTS
      toEnum x = throw $ UnknownTrafficSelectorKind x

data SharedSecretType = SharedIKE
                      | SharedEAP
                      | SharedRSA
                      | SharedPIN
                      deriving (Eq, Show)

instance Enum SharedSecretType where
      fromEnum SharedIKE = 1
      fromEnum SharedEAP = 2
      fromEnum SharedRSA = 3
      fromEnum SharedPIN = 4
      toEnum 1 = SharedIKE
      toEnum 2 = SharedEAP
      toEnum 3 = SharedRSA
      toEnum 4 = SharedPIN
      toEnum x = throw $ UnknownSharedSecretType x

instance Bounded SharedSecretType where
  minBound = SharedIKE
  maxBound = SharedPIN

data IKEConfig = IKEConfig {
                    _ikeId            :: Maybe Int,
                    _ikeReqCert       :: Bool,
                    _ikeForceEncap    :: Bool,
                    _ikeLocalAddress  :: Text,
                    _ikeRemoteAddress :: Text
                 } deriving (Eq, Show)

instance Default IKEConfig where
    def = IKEConfig {
              _ikeId            = Nothing,
              _ikeReqCert       = True,
              _ikeForceEncap    = False,
              _ikeLocalAddress  = "0.0.0.0",
              _ikeRemoteAddress = "0.0.0.0"
          }

data ChildSAConfig = ChildSAConfig {
                         _childSAId            :: Maybe Int,
                         _childSAName          :: Text,
                         _childSALifeTime      :: Word32,
                         _childSARekeyTime     :: Word32,
                         _childSAJitter        :: Word32,
                         _childSAUpDown        :: Maybe Text,
                         _childSAHostAccess    :: Bool,
                         _childSAMode          :: SAMode,
                         _childSAStartAction   :: SAAction,
                         _childSADPDAction     :: SAAction,
                         _childSACloseAction   :: SAAction,
                         _childSAIPCompression :: Bool,
                         _childSAReqID         :: Word32,
                         _childSAMark          :: Maybe Text
                     } deriving (Eq, Show)

instance Default ChildSAConfig where
    def = ChildSAConfig {
              _childSAId            = Nothing,
              _childSAName          = "",
              _childSALifeTime      = 1500,
              _childSARekeyTime     = 1200,
              _childSAJitter        = 60,
              _childSAUpDown        = Nothing,
              _childSAHostAccess    = False,
              _childSAMode          = Tunnel,
              _childSAStartAction   = None,
              _childSADPDAction     = None,
              _childSACloseAction   = None,
              _childSAIPCompression = False,
              _childSAReqID         = 0,
              _childSAMark          = Nothing
          }

data PeerConfig = PeerConfig {
                      _peerCfgId          :: Maybe Int,
                      _peerCfgName        :: Text,
                      _peerCfgIKEVersion  :: Word8,
                      _peerCfgIKEConfigId :: Maybe Int,
                      _peerCfgLocalId     :: Maybe Int,
                      _peerCfgRemoteId    :: Maybe Int,
                      _peerCfgCertPolicy  :: CertPolicy,
                      _peerCfgUniqueIds   :: Bool,
                      _peerCfgAuthMethod  :: AuthMethod,
                      _peerCfgEAPType     :: EAPType,
                      _peerCfgEAPVendor   :: Word16,
                      _peerCfgKeyingTries :: Word8,
                      _peerCfgRekeyTime   :: Word32,
                      _peerCfgReauthTime  :: Word32,
                      _peerCfgJitter      :: Word32,
                      _peerCfgOverTime    :: Word32,
                      _peerCfgMobike      :: Bool,
                      _peerCfgDPDDelay    :: Word32,
                      _peerCfgVirtual     :: Maybe Text,
                      _peerCfgPool        :: Maybe Text,
                      _peerCfgMediation   :: Bool,
                      _peerCfgMediatedBy  :: Int,
                      _peerCfgPeerId      :: Int
                  } deriving (Eq, Show)

instance Default PeerConfig where
    def = PeerConfig {
            _peerCfgId          = Nothing,
            _peerCfgName        = "",
            _peerCfgIKEVersion  = 2,
            _peerCfgIKEConfigId = Nothing,
            _peerCfgLocalId     = Nothing,
            _peerCfgRemoteId    = Nothing,
            _peerCfgCertPolicy  = SendIfAsked,
            _peerCfgUniqueIds   = True,
            _peerCfgAuthMethod  = PubKey,
            _peerCfgEAPType     = EAPUnspecified,
            _peerCfgEAPVendor   = 0,
            _peerCfgKeyingTries = 3,
            _peerCfgRekeyTime   = 7200,
            _peerCfgReauthTime  = 0,
            _peerCfgJitter      = 180,
            _peerCfgOverTime    = 300,
            _peerCfgMobike      = True,
            _peerCfgDPDDelay    = 120,
            _peerCfgVirtual     = Nothing,
            _peerCfgPool        = Nothing,
            _peerCfgMediation   = False,
            _peerCfgMediatedBy  = 0,
            _peerCfgPeerId      = 0
          }

data Peer2ChildConfig = Peer2ChildConfig {
                            p2cPeerCfgId  :: Int,
                            p2cChildCfgId :: Int
                        } deriving Show

data TrafficSelector = TrafficSelector {
                            _tsId        :: Maybe Int,
                            _tsType      :: TrafficSelectorType,
                            _tsProtocol  :: Word16,
                            _tsStartAddr :: IP,
                            _tsEndAddr   :: IP,
                            _tsStartPort :: PortNumber,
                            _tsEndPort   :: PortNumber
                        } deriving (Eq, Show)

instance Default TrafficSelector where
    def = TrafficSelector {
              _tsId = Nothing,
              _tsType = IPv4AddrRange,
              _tsProtocol  = 0,
              _tsStartAddr = "0.0.0.0",
              _tsEndAddr   = "255.255.255.255",
              _tsStartPort = 0,
              _tsEndPort   = 65535
          }

data Child2TSConfig = Child2TSConfig {
                            c2tsChildCfgId           :: Int,
                            c2tsTrafficSelectorCfgId :: Int,
                            c2tsTrafficSelectorKind  :: TrafficSelectorKind
                      } deriving Show

data SharedSecret = SharedSecret {
                        _ssId   :: Maybe Int,
                        _ssType :: SharedSecretType,
                        _ssData :: ByteString
                      } deriving Show

instance Default SharedSecret where
    def = SharedSecret Nothing SharedIKE ""

data SharedSecretIdentity = SharedSecretIdentity {
                                  _sharedSecretId :: Int,
                                  _identityId     :: Int
                            }

data PreparedStatements a = PreparedStatements {
                              updateChildSAStmt      :: a,
                              createChildSAStmt      :: a,
                              findChildSAStmt        :: a,
                              findChildSAByNameStmt  :: a,
                              deleteChildSAStmt      :: a,
                              updateIKEStmt          :: a,
                              createIKEStmt          :: a,
                              findIKEStmt            :: a,
                              deleteIKEStmt          :: a,
                              updatePeerStmt         :: a,
                              createPeerStmt         :: a,
                              findPeerStmt           :: a,
                              findPeerByNameStmt     :: a,
                              deletePeerStmt         :: a,
                              updateP2CStmt          :: a,
                              createP2CStmt          :: a,
                              findP2CStmt            :: a,
                              deleteP2CStmt          :: a,
                              updateTSStmt           :: a,
                              createTSStmt           :: a,
                              findTSStmt             :: a,
                              deleteTSStmt           :: a,
                              updateC2TSStmt         :: a,
                              createC2TSStmt         :: a,
                              findC2TSStmt           :: a,
                              deleteC2TSStmt         :: a,
                              updateIdentityStmt     :: a,
                              createIdentityStmt     :: a,
                              findIdentityStmt       :: a,
                              findIdentityBySelfStmt :: a,
                              deleteIdentityStmt     :: a,
                              updateSharedSecretStmt :: a,
                              createSharedSecretStmt :: a,
                              findSharedSecretStmt   :: a,
                              deleteSharedSecretStmt :: a,
                              updateSSIdentityStmt   :: a,
                              createSSIdentityStmt   :: a,
                              findSSIdentityStmt     :: a,
                              deleteSSIdentityStmt   :: a,
                              createIPSecStmt        :: a,
                              findIPSecStmt          :: a,
                              deleteIPSecStmt        :: a
                          } deriving (Show, Functor, Foldable)

-- | The managed IPsec configuration type encompasses a complete set of elements which are pushed and interlinked
-- as necessary by the /Managed/ API (see above). Note that there are lenses available to facilitate accessing all
-- these fields (see "StrongSwan.SQL.Lenses")
data IPSecSettings = IPSecSettings {
                        _getIPSecCfgName          :: Text,
                        _getIKEConfig             :: IKEConfig,
                        _getChildSAConfig         :: ChildSAConfig,
                        _getPeerConfig            :: PeerConfig,
                        _getLocalTrafficSelector  :: TrafficSelector,
                        _getRemoteTrafficSelector :: TrafficSelector,
                        _getLocalIdentity         :: Identity,
                        _getRemoteIdentity        :: Identity
                      } deriving (Eq, Show)

instance Default IPSecSettings where
    def = IPSecSettings "" def def def def def def def