did search & structure with new type system, split in multiple files

app/Main.hs

@@ -7,15 +7,13 @@ import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Servant.Client
 
 import HAL.Client
-
-basicSearch = search ["docid", "label_s"]
+import HAL.Doc
+import Tree
 
 main :: IO ()
 main = do
   manager' <- newManager tlsManagerSettings
-  res <- runClientM
-    (basicSearch ["docType_s:(THESE OR HDR)"] (asc "docid") (Just 1) (Just 2))
-    (mkClientEnv manager' $ BaseUrl Https "api.archives-ouvertes.fr" 443 "")
+  res <- runStructureRequest $ Just "parentDocid_i:302102"
   case res of
     (Left err) -> print err
     (Right val) -> print val

package.yaml

@@ -34,6 +34,7 @@ dependencies:
 - split
 - scientific
 - vector
+- data-default
 
 library:
   source-dirs: src

src/HAL/Client.hs

@@ -20,11 +20,12 @@ import qualified Codec.Binary.UTF8.String as UTF
 
 import Control.Lens as L (makeLenses)
 
-type HALAPI doc = (Search doc) :<|> (Structure doc)
+type HALAPI doc = Search doc
+  :<|> Structure doc
 
 type Search doc = "search"
   -- fl determine which fields will be returned it can be a list of fields or *
-  :> QueryParams "fl" Text
+  :> QueryParam "fl" doc
   -- TODO: type this monster
   -- fq is to filter request
   :> QueryParams "fq" Text
@@ -37,12 +38,11 @@ type Search doc = "search"
   :> Get '[JSON] (Response doc)
 
 type Structure doc = "ref" :> "structure"
+  :> QueryParam "fl" doc
   :> QueryParam "fq" Text
-  :> QueryParam "fl" Text
   :> QueryParam "rows" Int
   :> Get '[JSON] (Response doc)
 
-
 -- Get's argument type
 data SortField = Asc Text | Desc Text
   deriving (Show)
@@ -80,30 +80,28 @@ data Response doc = Response
   } deriving (Show, Generic)
 L.makeLenses ''Response
 
-
 instance FromJSON doc => FromJSON (Response doc) where
   parseJSON (Object o) = Response <$>
                          ((o .: "response") >>= (.: "numFound"))
                          <*> ((o .: "response") >>= (.: "start"))
                          <*> ((o .: "response") >>= (.: "docs"))
 
-
 halAPI :: Proxy (HALAPI doc)
 halAPI = Proxy
 
-structure :: FromJSON doc =>
-  Maybe Text -- fq
-  -> Maybe Text
-  -> Maybe Int -- rows
-  -> ClientM (Response doc)
-
 -- search should always have at least `docid` and `label_s` in his fl params
-search :: FromJSON doc =>
-  [Text] -- fl
+search :: (FromJSON doc, ToHttpApiData doc) =>
+  Maybe doc -- fl
   -> [Text] -- fq
   -> Maybe SortField -- sort
   -> Maybe Int -- start
   -> Maybe Int -- rows
   -> ClientM (Response doc)
 
+structure :: (FromJSON doc, ToHttpApiData doc) =>
+  Maybe doc
+  -> Maybe Text -- fq
+  -> Maybe Int -- rows
+  -> ClientM (Response doc)
+
 (search :<|> structure) = client halAPI

src/HAL/Doc.hs

+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module HAL.Doc where
+
+import GHC.Generics
+
+import Data.Aeson ((.:), (.:?), (.!=), Value(..), ToJSON, FromJSON(..), encode)
+import Data.Default
+import Data.Text (pack, Text)
+
+import Servant.API (ToHttpApiData(..))
+
+
+data Doc = Doc
+  {
+    _docid :: Int,
+    _label_s :: Maybe Text,
+    _parentDocid_i :: [Text]
+  } deriving (Generic)
+
+instance Default Doc where
+  def = Doc def def def
+
+instance FromJSON Doc where
+  parseJSON (Object o) = Doc <$>
+    (o .: "docid")
+    <*> (o .:? "label_s")
+    <*> (o .:? "parentDocid_i" .!= [])
+
+instance ToHttpApiData Doc where
+  toUrlPiece _ = "docid,label_s,parentDocid_i"
+
+instance Show Doc where
+  show (Doc id label _) = show label
+    <> "(" <> show id <> ")"
+

src/Tree.hs

 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Tree where
 
-import GHC.Generics
 import Network.HTTP.Client (newManager)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Servant.Client hiding (Response)
@@ -13,8 +11,6 @@ import Control.Lens.Getter ((^.))
 import Data.Map ((!?), (!), insert, empty, Map, fromList, toList)
 import qualified Data.Map as M
 import Data.Map.Internal (merge, preserveMissing, zipWithMatched)
-import Data.Text (pack, Text)
-import Data.Aeson (Value(..), ToJSON, encode)
 import Data.List (groupBy, isInfixOf)
 import Data.List.Split (chunksOf)
 import Data.Either (rights)
@@ -24,34 +20,17 @@ import qualified Data.Vector as V
 import Text.Printf
 
 import HAL.Client
-
-runHalAPIClient :: ClientM Response -> IO (Either ServantError Response)
-runHalAPIClient cmd = do
-  manager' <- newManager tlsManagerSettings
-  runClientM cmd (mkClientEnv manager' $ BaseUrl Https "api.archives-ouvertes.fr" 443 "")
-
-docid :: Doc -> Value
-docid (Doc doc) = doc ! "docid"
-
+import HAL.Doc
+{-
 formatParentIdRequest :: [Doc] -> Maybe Text
 formatParentIdRequest [] = Nothing
-formatParentIdRequest (x:[]) = Just . pack . show $ docid x
+formatParentIdRequest (x:[]) = Just . pack . show $ _docid x
 formatParentIdRequest (x:xs) =
-  (Just . pack . show $ docid x)
+  (Just . pack . show $ _docid x)
   <> (Just " || ")
   <> formatParentIdRequest xs
 
 
-runStructureRequest :: Maybe Text -> IO (Either ServantError Response)
-runStructureRequest rq =
-  runHalAPIClient $ structure rq (Just "docid, parentDocid_i, label_s") (Just 10000)
-
-scientific2text :: Scientific -> Text
-scientific2text n =
-  case floatingOrInteger n of
-    Left r  -> pack $ show (r :: Double)
-    Right i -> pack $ show (i :: Integer)
-
 ds2Child :: [Doc] -> IO [Doc]
 ds2Child ds =  do
   rs <- sequence $ runStructureRequest <$> formatedRequests ds
@@ -64,9 +43,9 @@ fetchChildren [] = pure []
 fetchChildren ds = (ds <>) <$> (fetchChildren =<< ds2Child ds)
 
 isChildOf :: Doc -> Doc -> Bool
-isChildOf (Doc d) (Doc d') = not . null $ V.filter (\id -> id == (scientific2text docId)) ((\(String a) -> a) <$> parentDocIds)
-  where (Number docId ) = (d ! "docid")
-        (Array parentDocIds) = (d' ! "parentDocid_i")
+isChildOf (Doc i l) (Doc i' l') = not . null $ V.filter (\id -> id == (scientific2text docId)) ((\(String a) -> a) <$> parentDocIds)
+  where (Number docId ) = d ! "docid"
+        (Array parentDocIds) = d' ! "parentDocid_i"
 
 data DocTree = DocTree Doc Int [DocTree]
   deriving (Show, Generic)
@@ -101,3 +80,5 @@ removeDuplicate deepMap tree@(DocTree doc depth children) = DocTree doc depth (r
 
 noDuplicateTree :: DocTree -> DocTree
 noDuplicateTree tree = removeDuplicate (findDeepest M.empty tree) tree
+
+-}