{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
module SAML2.XML.Schema.Datatypes where
import Prelude hiding (String)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Base64 as B64
import Data.Char (isDigit)
import Data.Char.Properties.XMLCharProps (isXmlSpaceChar, isXmlNameChar)
import Data.Fixed (Pico, showFixed)
import qualified Data.Time.Clock as Time
import Data.Time.Format (formatTime, parseTimeM, defaultTimeLocale)
import Data.Word (Word16)
import qualified Network.URI as URI
import qualified Text.XML.HXT.Arrow.Pickle.Schema as XPS
import Text.XML.HXT.DOM.QualifiedName (isNCName)
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Text.XML.HXT.XMLSchema.DataTypeLibW3CNames as XSD
import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP
type String = [Char]
xpString :: XP.PU String
xpString = XP.xpTextDT (XPS.scDTxsd XSD.xsd_string [])
type Boolean = Bool
xpBoolean :: XP.PU Boolean
xpBoolean = XP.xpWrapEither
( \s -> case s of
"true" -> Right True
"false" -> Right False
"1" -> Right True
"0" -> Right False
_ -> Left "invalid boolean"
, \b -> if b then "true" else "false"
) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_boolean []
type Duration = Time.NominalDiffTime
xpDuration :: XP.PU Duration
xpDuration = XP.xpWrapEither
( maybe (Left "invalid duration") (Right . realToFrac) . prd
, \t -> (if signum t < 0 then ('-':) else id)
$ 'P':'T': showFixed True (abs $ realToFrac t :: Pico) ++ "S"
) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_duration [] where
prd ('-':s) = negate <$> prp s
prd ('+':s) = prp s
prd s = prp s
prp ('P':s) = pru (0 :: Pico) prt [('Y',31556952),('M',2629746),('D',86400)] s
prp _ = Nothing
prt x "" = Just x
prt x ('T':s) = pru x prs [('H',3600),('M',60)] s
prt _ _ = Nothing
prs x "" = Just x
prs x s = case span isDigit s of
(d@(_:_),'.':(span isDigit -> (p,"S"))) -> Just $ x + read (d ++ '.' : p)
(d@(_:_),"S") -> Just $ x + read d
_ -> Nothing
pru x c ul s = case span isDigit s of
(d@(_:_),uc:sr) | (_,uv):ur <- dropWhile ((uc /=) . fst) ul -> pru (x + uv * read d) c ur sr
_ -> c x s
type DateTime = Time.UTCTime
xpDateTime :: XP.PU DateTime
xpDateTime = XP.PU
{ XP.theSchema = XPS.scDTxsd XSD.xsd_dateTime []
, XP.appPickle = XP.putCont . XN.mkText . formatTime defaultTimeLocale fmt
, XP.appUnPickle = XP.getCont >>= XP.liftMaybe "dateTime expects text" . XN.getText >>= parseTimeM True defaultTimeLocale fmtz
}
where
fmt = "%0Y-%m-%dT%H:%M:%S%Q"
fmtz = fmt ++ "%Z"
type Base64Binary = BS.ByteString
xpBase64Binary :: XP.PU Base64Binary
xpBase64Binary = XP.xpWrapEither
( B64.decode . BS.pack . filter (not . isXmlSpaceChar)
, BS.unpack . B64.encode
) $ XP.xpText0DT $ XPS.scDTxsd XSD.xsd_base64Binary []
type AnyURI = URI.URI
xpAnyURI :: XP.PU AnyURI
xpAnyURI = XP.xpWrapEither
( maybe (Left "invalid anyURI") Right . URI.parseURIReference
, \u -> URI.uriToString id u "")
$ XP.xpText0DT $ XPS.scDTxsd XSD.xsd_anyURI []
type NormalizedString = String
type Token = NormalizedString
type Language = Token
xpLanguage :: XP.PU Language
xpLanguage = XP.xpTextDT $ XPS.scDTxsd XSD.xsd_language []
type NMTOKEN = Token
isNMTOKEN :: Token -> Bool
isNMTOKEN [] = False
isNMTOKEN s = all isXmlNameChar s
xpNMTOKEN :: XP.PU NMTOKEN
xpNMTOKEN = XP.xpWrapEither
( \x -> if isNMTOKEN x then Right x else Left "NMTOKEN expected"
, id
) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_NMTOKEN []
type NMTOKENS = [NMTOKEN]
xpNMTOKENS :: XP.PU NMTOKENS
xpNMTOKENS = XP.xpWrapEither
( \x -> case words x of
[] -> Left "NMTOKENS expected"
l | all isNMTOKEN l -> Right l
_ -> Left "NMTOKENS expected"
, unwords
) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_NMTOKENS []
type ID = String
type NCName = String
xpNCName :: XP.PU NCName
xpNCName = XP.xpWrapEither
( \x -> if isNCName x then Right x else Left "NCName expected"
, id
) $ XP.xpTextDT $ XPS.scDTxsd XSD.xsd_NCName []
xpID :: XP.PU ID
xpID = xpNCName{ XP.theSchema = XPS.scDTxsd XSD.xsd_ID [] }
xpInteger :: XP.PU Integer
xpInteger = XP.xpPrim{ XP.theSchema = XPS.scDTxsd XSD.xsd_integer [] }
type NonNegativeInteger = Word
xpNonNegativeInteger :: XP.PU NonNegativeInteger
xpNonNegativeInteger = XP.xpPrim{ XP.theSchema = XPS.scDTxsd XSD.xsd_nonNegativeInteger [] }
type UnsignedShort = Word16
xpUnsignedShort :: XP.PU UnsignedShort
xpUnsignedShort = XP.xpPrim{ XP.theSchema = XPS.scDTxsd XSD.xsd_unsignedShort [] }
type PositiveInteger = NonNegativeInteger
xpPositiveInteger :: XP.PU PositiveInteger
xpPositiveInteger = XP.xpWrapEither
( \x -> if x > 0 then Right x else Left "0 is not positive"
, id
) $ XP.xpPrim{ XP.theSchema = XPS.scDTxsd XSD.xsd_positiveInteger [] }