strongswan-sql-1.0.0.0: src/StrongSwan/SQL/Encoding.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
module StrongSwan.SQL.Encoding where
import Control.Exception (throw)
import Data.ASN1.BinaryEncoding (DER(..))
import Data.ASN1.Encoding (encodeASN1', decodeASN1')
import Data.Bifunctor (second)
import Data.ByteString.Char8 (ByteString, unpack)
import Data.Maybe (fromJust)
import Data.Word (Word8)
import Numeric (showHex)
import StrongSwan.SQL.Types
import qualified Data.ByteString as B
import qualified Database.MySQL.Base as SQL
class SQLRow a where
toValues :: a -> [SQL.MySQLValue]
fromValues :: [SQL.MySQLValue] -> a
class SQLValue a where
toSQL :: a -> SQL.MySQLValue
fromSQL :: SQL.MySQLValue -> a
instance SQLValue (Value 'SQL.MySQLInt8U) where
toSQL (TinyInt x) = SQL.MySQLInt8U x
fromSQL (SQL.MySQLInt8U x) = TinyInt x
fromSQL (SQL.MySQLInt8 x) = TinyInt $ fromIntegral x
fromSQL v = throw $ InvalidValueForType "TinyInt" (show v)
instance SQLValue (Value 'SQL.MySQLInt16U) where
toSQL (SmallInt x) = SQL.MySQLInt16U x
fromSQL (SQL.MySQLInt16U x) = SmallInt x
fromSQL v = throw $ InvalidValueForType "SmallInt" (show v)
instance SQLValue (Value 'SQL.MySQLInt32U) where
toSQL (IntWord32 x) = SQL.MySQLInt32U x
fromSQL (SQL.MySQLInt32U x) = IntWord32 x
fromSQL v = throw $ InvalidValueForType "IntWord32" (show v)
instance SQLValue (Value 'SQL.MySQLBytes) where
toSQL (VarBinary bytes) = SQL.MySQLBytes bytes
fromSQL (SQL.MySQLBytes bytes) = VarBinary bytes
fromSQL v = throw $ InvalidValueForType "VarBinary" (show v)
instance SQLValue (Value 'SQL.MySQLText) where
toSQL (VarChar bytes) = SQL.MySQLText bytes
toSQL NullChar = SQL.MySQLNull
fromSQL (SQL.MySQLText bytes) = VarChar bytes
fromSQL SQL.MySQLNull = NullChar
fromSQL v = throw $ InvalidValueForType "VarChar" (show v)
instance SQLRow Identity where
toValues AnyID = [toSQL $ toTinyInt (0::Word8), toSQL $ toVarBinary "%any"]
toValues (IPv4AddrID v4) = [toSQL $ toTinyInt (1::Word8), toSQL $ toVarBinary v4]
toValues (NameID str) = [toSQL $ toTinyInt (2::Word8), toSQL $ toVarBinary str]
toValues (EmailID local domain) = [toSQL $ toTinyInt (3::Word8), toSQL $ toVarBinary (local ++ '@':domain)]
toValues (IPv6AddrID v6) = [toSQL $ toTinyInt (5::Word8), toSQL $ toVarBinary v6]
toValues (ASN1ID elements) = [toSQL $ toTinyInt (9::Word8), toSQL $ toVarBinary (encodeASN1' DER elements)]
toValues (OpaqueID bytes) = [toSQL $ toTinyInt (11::Word8), toSQL $ toVarBinary bytes]
fromValues [SQL.MySQLInt8U 0, _] = AnyID
fromValues [SQL.MySQLInt8U 1, v] = IPv4AddrID . fromVarBinary $ fromSQL v
fromValues [SQL.MySQLInt8U 2, v] = NameID . fromVarBinary $ fromSQL v
fromValues [SQL.MySQLInt8U 3, v] = uncurry EmailID . parseEmail . fromVarBinary $ fromSQL v
fromValues [SQL.MySQLInt8U 5, v] = IPv6AddrID . fromVarBinary $ fromSQL v
fromValues [SQL.MySQLInt8U 9, v] = ASN1ID . either throw id . decodeASN1' DER . fromVarBinary $ fromSQL v
fromValues v = throw $ SQLValuesMismatch "Identity" (show v)
parseEmail :: ByteString -> (String, String)
parseEmail = second (drop 1) . span (/= '@') . unpack
instance SQLRow IKEConfig where
toValues IKEConfig {..} = [
toSQL $ toTinyInt _ikeReqCert,
toSQL $ toTinyInt _ikeForceEncap,
toSQL . toVarChar $ Just _ikeLocalAddress,
toSQL . toVarChar $ Just _ikeRemoteAddress]
fromValues (iD :
reqCert :
forceEncap :
localAddress :
remoteAddress :
[]) = IKEConfig {
_ikeId = return . fromInt $ fromSQL iD,
_ikeReqCert = fromTinyInt $ fromSQL reqCert,
_ikeForceEncap = fromTinyInt $ fromSQL forceEncap,
_ikeLocalAddress = fromJust . fromVarChar $ fromSQL localAddress,
_ikeRemoteAddress = fromJust . fromVarChar $ fromSQL remoteAddress
}
fromValues xs = throw $ SQLValuesMismatch "IKEConfig" (show xs)
instance SQLRow ChildSAConfig where
toValues ChildSAConfig {..} = [
toSQL . toVarChar $ Just _childSAName,
toSQL $ toInt _childSALifeTime,
toSQL $ toInt _childSARekeyTime,
toSQL $ toInt _childSAJitter,
toSQL $ toVarChar _childSAUpDown,
toSQL $ toTinyInt _childSAHostAccess,
toSQL $ toTinyInt _childSAMode,
toSQL $ toTinyInt _childSAStartAction,
toSQL $ toTinyInt _childSADPDAction,
toSQL $ toTinyInt _childSACloseAction,
toSQL $ toTinyInt _childSAIPCompression,
toSQL $ toInt _childSAReqID ]
fromValues (iD:
name :
lifeTime :
rekeyTime :
jitter :
upDown :
hostAccess :
mode :
startAction :
dpdAction :
closeAction :
ipCompression :
reqID :
[]) = ChildSAConfig {
_childSAId = return . fromInt $ fromSQL iD,
_childSAName = fromJust . fromVarChar $ fromSQL name,
_childSALifeTime = fromInt $ fromSQL lifeTime,
_childSARekeyTime = fromInt $ fromSQL rekeyTime,
_childSAJitter = fromInt $ fromSQL jitter,
_childSAUpDown = fromVarChar $ fromSQL upDown,
_childSAHostAccess = fromTinyInt $ fromSQL hostAccess,
_childSAMode = fromTinyInt $ fromSQL mode,
_childSAStartAction = fromTinyInt $ fromSQL startAction,
_childSADPDAction = fromTinyInt $ fromSQL dpdAction,
_childSACloseAction = fromTinyInt $ fromSQL closeAction,
_childSAIPCompression = fromTinyInt $ fromSQL ipCompression,
_childSAReqID = fromInt $ fromSQL reqID
}
fromValues xs = throw $ SQLValuesMismatch "ChildSAConfig" (show xs)
instance SQLRow PeerConfig where
toValues PeerConfig {..} = [
toSQL . toVarChar $ Just _peerCfgName,
toSQL $ toTinyInt _peerCfgIKEVersion,
toSQL $ toInt _peerCfgIKEConfigId,
toSQL . toVarChar $ Just _peerCfgLocalId,
toSQL . toVarChar $ Just _peerCfgRemoteId,
toSQL $ toTinyInt _peerCfgCertPolicy,
toSQL $ toTinyInt _peerCfgUniqueIds,
toSQL $ toTinyInt _peerCfgAuthMethod,
toSQL $ toTinyInt _peerCfgEAPType,
toSQL $ toSmallInt _peerCfgEAPVendor,
toSQL $ toTinyInt _peerCfgKeyingTries,
toSQL $ toInt _peerCfgRekeyTime,
toSQL $ toInt _peerCfgReauthTime,
toSQL $ toInt _peerCfgJitter,
toSQL $ toInt _peerCfgOverTime,
toSQL $ toTinyInt _peerCfgMobike,
toSQL $ toInt _peerCfgDPDDelay,
toSQL $ toVarChar _peerCfgVirtual,
toSQL $ toVarChar _peerCfgPool,
toSQL $ toTinyInt _peerCfgMediation,
toSQL $ toInt _peerCfgMediatedBy,
toSQL $ toInt _peerCfgPeerId ]
fromValues (iD :
name :
ikeVersion :
ikeConfig :
localId :
remoteId :
certPolicy :
uniqueIds :
authMethod :
eapType :
eapVendor :
keyingTries :
rekeyTime :
reauthTime :
jitter :
overTime :
mobike :
dpdDelay :
virtual :
pool :
mediation :
mediatedBy :
peerId :
[]) = PeerConfig {
_peerCfgId = return . fromInt $ fromSQL iD,
_peerCfgName = fromJust . fromVarChar $ fromSQL name,
_peerCfgIKEVersion = fromTinyInt $ fromSQL ikeVersion,
_peerCfgIKEConfigId = fromInt $ fromSQL ikeConfig,
_peerCfgLocalId = fromJust . fromVarChar $ fromSQL localId,
_peerCfgRemoteId = fromJust . fromVarChar $ fromSQL remoteId,
_peerCfgCertPolicy = fromTinyInt $ fromSQL certPolicy,
_peerCfgUniqueIds = fromTinyInt $ fromSQL uniqueIds,
_peerCfgAuthMethod = fromTinyInt $ fromSQL authMethod,
_peerCfgEAPType = fromTinyInt $ fromSQL eapType,
_peerCfgEAPVendor = fromSmallInt $ fromSQL eapVendor,
_peerCfgKeyingTries = fromTinyInt $ fromSQL keyingTries,
_peerCfgRekeyTime = fromInt $ fromSQL rekeyTime,
_peerCfgReauthTime = fromInt $ fromSQL reauthTime,
_peerCfgJitter = fromInt $ fromSQL jitter,
_peerCfgOverTime = fromInt $ fromSQL overTime,
_peerCfgMobike = fromTinyInt $ fromSQL mobike,
_peerCfgDPDDelay = fromInt $ fromSQL dpdDelay,
_peerCfgVirtual = fromVarChar $ fromSQL virtual,
_peerCfgPool = fromVarChar $ fromSQL pool,
_peerCfgMediation = fromTinyInt $ fromSQL mediation,
_peerCfgMediatedBy = fromInt $ fromSQL mediatedBy,
_peerCfgPeerId = fromInt $ fromSQL peerId
}
fromValues xs = throw $ SQLValuesMismatch "PeerConfig" (show xs)
instance SQLRow Peer2ChildConfig where
toValues Peer2ChildConfig {..} = [
toSQL $ toInt p2cPeerCfgId,
toSQL $ toInt p2cChildCfgId ]
fromValues (peerId: childId: []) =
Peer2ChildConfig {
p2cPeerCfgId = fromInt $ fromSQL peerId,
p2cChildCfgId = fromInt $ fromSQL childId
}
fromValues xs = throw $ SQLValuesMismatch "Peer2ChildConfig" (show xs)
instance SQLRow TrafficSelector where
toValues TrafficSelector {..} = [
toSQL $ toTinyInt _tsType,
toSQL $ toSmallInt _tsProtocol,
toSQL $ toVarBinary _tsStartAddr,
toSQL $ toVarBinary _tsEndAddr,
toSQL $ toSmallInt _tsStartPort,
toSQL $ toSmallInt _tsEndPort ]
fromValues (iD :
type' :
protocol :
startAddr :
endAddr :
startPort :
endort :
[]) = TrafficSelector {
_tsId = return . fromInt $ fromSQL iD,
_tsType = fromTinyInt $ fromSQL type',
_tsProtocol = fromSmallInt $ fromSQL protocol,
_tsStartAddr = fromVarBinary $ fromSQL startAddr,
_tsEndAddr = fromVarBinary $ fromSQL endAddr,
_tsStartPort = fromSmallInt $ fromSQL startPort,
_tsEndPort = fromSmallInt $ fromSQL endort
}
fromValues xs = throw $ SQLValuesMismatch "TrafficSelector" (show xs)
instance SQLRow Child2TSConfig where
toValues Child2TSConfig {..} = [
toSQL $ toInt c2tsChildCfgId,
toSQL $ toInt c2tsTrafficSelectorCfgId,
toSQL $ toTinyInt c2tsTrafficSelectorKind ]
fromValues (childCfgId :
trafficSelectorCfgId :
trafficSelectorKind :
[]) = Child2TSConfig {
c2tsChildCfgId = fromInt $ fromSQL childCfgId,
c2tsTrafficSelectorCfgId = fromInt $ fromSQL trafficSelectorCfgId,
c2tsTrafficSelectorKind = fromTinyInt $ fromSQL trafficSelectorKind
}
fromValues xs = throw $ SQLValuesMismatch "Child2TSConfig" (show xs)
encodeHex :: ByteString -> String
encodeHex = B.foldr showHex ""