XML APIサーバーで使いたい
バックエンドの開発用サーバーを皆に黙って、こっそりYesodで作ろうかと思ってたら、メンテナーがいなくなることが判明し、全員に却下されることとなったが、いつかやってやろうと思っている。
でXML
YesodでXMLを出力する、TemplateHaskellを使うと結構簡単
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Home where
import Import
import Text.XML
import Text.Hamlet.XML
import qualified Data.Map as M
import qualified Text.XML.Stream.Render as R
getHomeR :: Handler TypedContent
getHomeR = selectRep $ do
provideRep $ return $ repXml $ renderText rs (getXml 10)
getXml :: Int -> Document
getXml n = Document p elm []
where
p = Prologue [] Nothing []
elm = Element "root" M.empty [xml|
<params>
<param>#{pack $ show n}
<param>yyy
|]
rs :: R.RenderSettings
rs = def
Handler部分だけですが、TypedContentとrepXmlでcontent-type/xmlに変えて、Document型を返す関数をrenderText関数へ食わせるだけ。
THとか使わない版
ベタに書くとこんな感じか、オレオレデータをXMLに無理やり変換してるだけ、あまり綺麗じゃないので許してね
{-# LANGUAGE OverloadedStrings #-}
import Text.XML
import qualified Data.Text as T
import qualified Data.Text.Internal as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.Internal.Lazy as L
import qualified Data.Map as M
data Foo = Foo {
identFoo :: Int
, namefoo :: T.Text
, argList :: [Argument]
} deriving(Show)
data Argument = Argument {
nameArg :: T.Text
, dataArg :: Maybe T.Text
} deriving(Show)
data Other = Other {
identOther :: Int
, nameOther :: T.Text
} deriving(Show)
main :: IO ()
main = putStrLn $ T.unpack $ L.toStrict $
renderText (def :: RenderSettings) $ createDoc $ (foos createFoo) ++ (others createOther)
createDoc :: [Node] -> Document
createDoc nodes = Document prlg elem []
where
prlg = Prologue [] Nothing []
elem = Element (Name "root" Nothing Nothing) M.empty nodes
foos :: [Foo] -> [Node]
foos = map (fooNodes)
others :: [Other] -> [Node]
others = map (otherNodes)
node :: Int -> T.Text -> M.Map Name T.Text
node i name = M.fromList [
(Name "id" Nothing Nothing, (T.pack $ show i))
, (Name "name" Nothing Nothing, name)
]
fooNodes :: Foo -> Node
fooNodes f@(Foo i name arg) = NodeElement elem
where
elem = Element n
(node i name)
nodes
n = Name "foo" Nothing Nothing
nodes = map (\(Argument an dt) ->
NodeElement
(Element (Name "argument" Nothing Nothing)
(M.fromList [(Name "name" Nothing Nothing, an)])
(nodeCont dt))
) arg
otherNodes :: Other -> Node
otherNodes o@(Other i name) = NodeElement elem
where
elem = Element n
(node i name)
[]
n = Name "other" Nothing Nothing
nodeCont :: Maybe T.Text -> [Node]
nodeCont (Just val) = [NodeContent val]
nodeCont _ = []
createFoo :: [Foo]
createFoo = [Foo 1 "test" createArgument, Foo 2 "test2" createArguments]
createArgument :: [Argument]
createArgument = [Argument "a" (Just "empty 吉田")]
createArguments :: [Argument]
createArguments = [Argument "b" (Just "エンペラー 吉田"), Argument "c" Nothing]
createOther :: [Other]
createOther = [Other 2 "someother"]
{-
<?xml version="1.0" encoding="UTF-8"?>
<root>
<foo id="1" name="test">
<argument name="a">empty 吉田</argument>
</foo>
<foo id="2" name="test2">
<argument name="b">エンペラー 吉田</argument>
<argument name="c"/>
</foo>
<other id="2" name="someother"/>
</root>
-}
とりあえず、吉田さんのとこに上げときます
https://github.com/calimakvo/resp-xml
