108 lines
3.0 KiB
Haskell
108 lines
3.0 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
|
|
|
|
module Api
|
|
( fetchCollections,
|
|
createCollection,
|
|
fetchSchema,
|
|
fetchSchemaVersion,
|
|
fetchPosts,
|
|
fetchPost,
|
|
updatePost,
|
|
)
|
|
where
|
|
|
|
#ifndef ghcjs_HOST_OS
|
|
import Data.String
|
|
import Network.HTTP.Simple
|
|
#else
|
|
import Data.ByteString.Char8 qualified as B
|
|
import Data.Maybe
|
|
import Data.String
|
|
import JavaScript.Web.XMLHttpRequest
|
|
import Miso.String qualified as J
|
|
#endif
|
|
import Data.Aeson qualified as A
|
|
import Data.ByteString.Lazy.Char8 qualified as LB
|
|
import Data.ByteString.Lazy.UTF8 qualified as LB
|
|
import Data.Function
|
|
import Miso
|
|
import Safe
|
|
import Schema
|
|
import Version
|
|
|
|
fetchCollections :: JSM (Either String [String])
|
|
fetchCollections =
|
|
A.eitherDecode <$> fetch (fromString "http://localhost:8081/collections")
|
|
|
|
createCollection :: String -> JSM (Either String ())
|
|
createCollection collection =
|
|
A.eitherDecode
|
|
<$> fetch
|
|
( fromString "http://localhost:8081/collections"
|
|
& setRequestMethod "POST"
|
|
& setRequestBodyLBS (A.encode (A.toJSON collection))
|
|
)
|
|
|
|
fetchSchemaVersion :: JSM (Either String Version)
|
|
fetchSchemaVersion =
|
|
A.eitherDecode <$> fetch (fromString "http://localhost:8081/schemaVersion")
|
|
|
|
fetchSchema :: JSM (Either String Schema)
|
|
fetchSchema =
|
|
A.eitherDecode <$> fetch (fromString "http://localhost:8081/posts.schema.json")
|
|
|
|
fetchPosts :: JSM (Either String [A.Value])
|
|
fetchPosts =
|
|
A.eitherDecode
|
|
<$> fetch
|
|
( fromString "http://localhost:8081"
|
|
& setRequestMethod "POST"
|
|
& setRequestBodyLBS "SELECT posts FROM posts"
|
|
)
|
|
|
|
fetchPost :: String -> JSM (Either String (Maybe A.Value))
|
|
fetchPost fileName =
|
|
fmap headMay . A.eitherDecode
|
|
<$> fetch
|
|
( fromString "http://localhost:8081"
|
|
& setRequestMethod "POST"
|
|
& setRequestBodyLBS ("SELECT posts FROM posts WHERE posts.$fileName == \"" <> LB.fromString fileName <> "\"")
|
|
)
|
|
|
|
updatePost :: String -> A.Value -> JSM (Either String ())
|
|
updatePost fileName value =
|
|
A.eitherDecode
|
|
<$> fetch
|
|
( fromString "http://localhost:8081"
|
|
& setRequestMethod "POST"
|
|
& setRequestBodyLBS ("UPDATE posts SET " <> A.encode value <> " WHERE posts.$fileName == \"" <> LB.fromString fileName <> "\"")
|
|
)
|
|
|
|
fetch :: Request -> JSM LB.ByteString
|
|
fetch req = LB.fromStrict . getResponseBody <$> httpBS req
|
|
|
|
#ifdef ghcjs_HOST_OS
|
|
httpBS :: Request -> JSM (Response B.ByteString)
|
|
httpBS req = xhrByteString req
|
|
|
|
instance IsString Request where
|
|
fromString uri =
|
|
Request
|
|
{ reqMethod = GET,
|
|
reqURI = J.pack uri,
|
|
reqLogin = Nothing,
|
|
reqHeaders = [],
|
|
reqWithCredentials = False,
|
|
reqData = NoData
|
|
}
|
|
|
|
setRequestMethod :: B.ByteString -> Request -> Request
|
|
setRequestMethod "POST" req = req {reqMethod = POST}
|
|
|
|
setRequestBodyLBS :: LB.ByteString -> Request -> Request
|
|
setRequestBodyLBS body req = req {reqData = StringData (J.pack (LB.unpack body))}
|
|
|
|
getResponseBody :: Response B.ByteString -> B.ByteString
|
|
getResponseBody = fromMaybe "" . contents
|
|
#endif
|