{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# 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
| UTF8
| UCS2
| UTF16
| UTF16LE
| UTF32
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)
| IPv4AddrID (Maybe Int) IPv4
| NameID (Maybe Int) Text
| EmailID (Maybe Int) Text Text
| IPv6AddrID (Maybe Int) IPv6
| ASN1ID (Maybe Int) [ASN1]
| OpaqueID (Maybe Int) ByteString
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
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 = "0.0.0.0",
_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 = PreparedStatements {
updateChildSAStmt :: SQL.StmtID,
createChildSAStmt :: SQL.StmtID,
findChildSAStmt :: SQL.StmtID,
findChildSAByNameStmt :: SQL.StmtID,
deleteChildSAStmt :: SQL.StmtID,
updateIKEStmt :: SQL.StmtID,
createIKEStmt :: SQL.StmtID,
findIKEStmt :: SQL.StmtID,
deleteIKEStmt :: SQL.StmtID,
updatePeerStmt :: SQL.StmtID,
createPeerStmt :: SQL.StmtID,
findPeerStmt :: SQL.StmtID,
findPeerByNameStmt :: SQL.StmtID,
deletePeerStmt :: SQL.StmtID,
updateP2CStmt :: SQL.StmtID,
createP2CStmt :: SQL.StmtID,
findP2CStmt :: SQL.StmtID,
deleteP2CStmt :: SQL.StmtID,
updateTSStmt :: SQL.StmtID,
createTSStmt :: SQL.StmtID,
findTSStmt :: SQL.StmtID,
deleteTSStmt :: SQL.StmtID,
updateC2TSStmt :: SQL.StmtID,
createC2TSStmt :: SQL.StmtID,
findC2TSStmt :: SQL.StmtID,
deleteC2TSStmt :: SQL.StmtID,
updateIdentityStmt :: SQL.StmtID,
createIdentityStmt :: SQL.StmtID,
findIdentityStmt :: SQL.StmtID,
findIdentityBySelfStmt :: SQL.StmtID,
deleteIdentityStmt :: SQL.StmtID,
updateSharedSecretStmt :: SQL.StmtID,
createSharedSecretStmt :: SQL.StmtID,
findSharedSecretStmt :: SQL.StmtID,
deleteSharedSecretStmt :: SQL.StmtID,
updateSSIdentityStmt :: SQL.StmtID,
createSSIdentityStmt :: SQL.StmtID,
findSSIdentityStmt :: SQL.StmtID,
deleteSSIdentityStmt :: SQL.StmtID,
createIPSecStmt :: SQL.StmtID,
findIPSecStmt :: SQL.StmtID,
deleteIPSecStmt :: SQL.StmtID
} deriving Show
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