Basic queries to cidianwang.com now working

However, needs patch to servant-client. See haskell-servant/servant#1097 .
edsko · Dec 15, 2018 · 7aaadac · 7aaadac
1 parent 70b3051
commit 7aaadac
Show file tree

Hide file tree

Showing 5 changed files with 70 additions and 13 deletions.
diff --git a/QuerySFZD.cabal b/QuerySFZD.cabal
@@ -30,7 +30,6 @@ executable QuerySFZD
                      , blaze-html
                      , blaze-markup
                      , bytestring
-                     , http-api-data
                      , http-client
                      , servant
                      , servant-blaze

diff --git a/src/QuerySFZD/API/Theirs/CiDianWang.hs b/src/QuerySFZD/API/Theirs/CiDianWang.hs
@@ -1,8 +1,12 @@
-{-# LANGUAGE DataKinds     #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators     #-}
 
 module QuerySFZD.API.Theirs.CiDianWang (
     API
+  , Query(..)
+  , Style(..)
+  , Referer(..)
   , api
   , module Export
   ) where
@@ -14,8 +18,44 @@ import Servant.HTML.Blaze
 import QuerySFZD.API.Theirs.CiDianWang.Results as Export
 import QuerySFZD.API.Theirs.Common
 
-type API = QueryParam' '[Required] "q" SingleChar
+
+-- > http://search.cidianwang.com/?m=8&q=好&z=输入书法家&y=3
+type API = QueryParam' '[Required] "m" Query
+        :> QueryParam' '[Required] "q" SingleChar
+        :> QueryParam' '[Required] "z" Author
+        :> QueryParam' '[Required] "y" Style
+        :> Header' '[] "Referer" Referer
         :> Get '[HTML] Results
 
+data Query = Calligraphy
+
+instance ToHttpApiData Query where
+  toQueryParam Calligraphy = "8"
+
+data Referer =
+    -- | cidiangwang.com responds with a 404 if this is not set
+    RefererSelf
+
+instance ToHttpApiData Referer where
+  toQueryParam RefererSelf = "http://www.cidianwang.com/shufa/"
+
 api :: Proxy API
 api = Proxy
+
+data Style =
+    AllStyles   -- ^ 不限
+  | SemiCursive -- ^ 行书
+  | Regular     -- ^ 楷书
+  | Cursive     -- ^ 草书
+  | Clerical    -- ^ 隶书
+  | Seal        -- ^ 篆书
+  | Small       -- ^ 小楷
+
+instance ToHttpApiData Style where
+  toQueryParam AllStyles   = "5"
+  toQueryParam SemiCursive = "0"
+  toQueryParam Regular     = "1"
+  toQueryParam Cursive     = "2"
+  toQueryParam Clerical    = "3"
+  toQueryParam Seal        = "4"
+  toQueryParam Small       = "6"
diff --git a/src/QuerySFZD/API/Theirs/Common.hs b/src/QuerySFZD/API/Theirs/Common.hs
@@ -1,10 +1,17 @@
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module QuerySFZD.API.Theirs.Common (
     SingleChar(..)
+  , Author(..)
   ) where
 
-import Web.HttpApiData
+import Servant
 
 newtype SingleChar = SingleChar Char
 
 instance ToHttpApiData SingleChar where
   toQueryParam (SingleChar c) = toQueryParam [c]
+
+newtype Author = Author String
+  deriving newtype ToHttpApiData
diff --git a/src/QuerySFZD/Client/CiDianWang.hs b/src/QuerySFZD/Client/CiDianWang.hs
@@ -16,5 +16,10 @@ baseUrl = BaseUrl {
     , baseUrlPath   = ""
     }
 
-query :: SingleChar -> ClientM Results
+query :: Query
+      -> SingleChar
+      -> Author
+      -> Style
+      -> Maybe Referer
+      -> ClientM Results
 query = client api
diff --git a/src/QuerySFZD/Server.hs b/src/QuerySFZD/Server.hs
@@ -9,26 +9,32 @@ import Servant
 import Servant.Client
 
 import           QuerySFZD.API.Ours
-import qualified QuerySFZD.API.Theirs.CiDianWang as CiDianWang
+import qualified QuerySFZD.API.Theirs.CiDianWang as CDW
 import           QuerySFZD.API.Theirs.Common
-import qualified QuerySFZD.Client.CiDianWang as CiDianWang
+import qualified QuerySFZD.Client.CiDianWang as CDW
 
 server :: Manager -> Server API
 server mgr =
          return IndexPage
     :<|> query mgr
 
 query :: Manager -> Characters -> Handler Results
-query mgr (Characters [c]) = do
-    mRes <- liftIO $ runClientM (CiDianWang.query (SingleChar c)) clientEnv
+query mgr (Characters cs) = do
+    let q = CDW.query
+              CDW.Calligraphy
+              (SingleChar (head cs))
+              (Author "")
+              CDW.SemiCursive
+              (Just CDW.RefererSelf)
+    mRes <- liftIO $ runClientM q clientEnv
     case mRes of
       Left err ->
         throwError $ err501 { errBody = fromString (renderErr err) }
-      Right (CiDianWang.Results r) ->
-        return $ Results [c] r
+      Right (CDW.Results r) ->
+        return $ Results cs r
   where
     clientEnv :: ClientEnv
-    clientEnv = mkClientEnv mgr CiDianWang.baseUrl
+    clientEnv = mkClientEnv mgr CDW.baseUrl
 
     renderErr :: ServantError -> String
     renderErr err = "cidianwang.com reported error: " ++ show err