hs-rqlite (empty) → 0.1.0.0
raw patch · 6 files changed
+403/−0 lines, 6 filesdep +HTTPdep +aesondep +basesetup-changed
Dependencies added: HTTP, aeson, base, bifunctors, bytestring, containers, scientific, text, unordered-containers
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- hs-rqlite.cabal +33/−0
- src/Rqlite.hs +245/−0
- src/Rqlite/Status.hs +88/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hs-rqlite++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019 Konstantinos Dermentzis, k.dermenz@gmail.com++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of kderme nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hs-rqlite.cabal view
@@ -0,0 +1,33 @@+cabal-version: 2.2+name: hs-rqlite+version: 0.1.0.0+synopsis: A Haskell client for RQlite+description: See README at <https://github.com/kderme/hs-rqlite/blob/master/README.md>+bug-reports: https://github.com/kderme/hs-rqlite/issues+license: BSD-3-Clause+license-file: LICENSE+author: Konstantinos Dermentzis <k.dermenz@gmail.com>+maintainer: Konstantinos Dermentzis <k.dermenz@gmail.com>+copyright: Konstantinos Dermentzis <k.dermenz@gmail.com>+category: Database+extra-source-files: CHANGELOG.md++library+ hs-source-dirs: src+ exposed-modules: Rqlite+ , Rqlite.Status+ build-depends: base >= 4.12.0 && < 4.13+ , aeson >= 1.4.2 && < 1.5+ , bifunctors >= 5.5.3 && < 5.6+ , bytestring >= 0.10.8 && < 0.11+ , containers >= 0.6.0 && < 0.7+ , HTTP >= 4000.3.14 && < 4000.4+ , scientific >= 0.3.6 && < 0.4+ , text >= 1.2.3 && < 1.3+ , unordered-containers >= 0.2.9 && < 0.3+ ghc-options: -Wall+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/kderme/hs-rqlite
+ src/Rqlite.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Rqlite+ ( --posts+ PostResult(..)+ , postQueries+ , postQuery+ -- gets+ , GetResult(..)+ , getQuery+ , Level(..)+ -- exceptions+ , RQliteError(..)+ , reify+ ) where++import Control.Exception+import Data.Aeson hiding (Result)+import Data.List (find, intercalate)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.ByteString.Char8 as Char8+import Data.Scientific+import Data.Typeable+import qualified Data.HashMap.Strict as M+import GHC.Generics+import GHC.IO.Exception+import Network.HTTP hiding (host)+import Network.Stream++data RQResult a =+ RQResults { results :: [a]}+ | RQLeaderError Text+ deriving (Show, Read, Generic)++instance FromJSON a => FromJSON (RQResult a) where+ parseJSON j = do+ Object o <- parseJSON j+ case M.toList (o :: Object) of+ [("results", x)] -> do+ ls <- parseJSON x+ return $ RQResults ls+ [("error", String err)] | Text.isPrefixOf "leadership lost" err ->+ return $ RQLeaderError err+ _ -> throw $ UnexpectedResponse $ concat+ ["Failed to decode ", show j]++-- Post Requests --++data PostResult+ = PostResult { last_insert_id :: Int }+ | EmptyPostResult+ | PostError Text -- this indicates an SQlite error, returned by rqlite.+ deriving (Show, Read, Generic)++instance FromJSON PostResult where+ parseJSON j = do+ Object o <- parseJSON j+ case M.toList (o :: Object) of+ [("rows_affected", _), ("last_insert_id", Number n)] ->+ return $ PostResult $ base10Exponent n+ [("last_insert_id", Number n)] -> -- this happens when deleting+ return $ PostResult $ base10Exponent n+ [("error", String txt)] ->+ return $ PostError txt+ [] -> -- this happens when creating table+ return EmptyPostResult+ _ -> throw $ UnexpectedResponse $ concat+ ["Failed to decode ", show j, " as PostResult"]++post :: String -> String -> IO (Either (Response String) String)+post request body = do+ reifyRed $ simpleHTTP $ postRequestWithBody+ request+ "application/json"+ body++postQueries :: Bool -> String -> [String] -> IO [PostResult]+postQueries redirect host queries = do+ let body = concat+ [ "["+ , intercalate "," (fmap (\str -> concat [" \"", str, "\" "]) queries)+ , "]"+ ]+ go :: Int -> String -> [Response String] -> IO [PostResult]+ go 5 _ acc = throwIO $ MaxNumberOfRedirections $ reverse acc+ go n req acc = do+ mResp <- post req body+ case mResp of+ Right resp -> do+ let postResults = getLastInsertId resp+ if length postResults /= length queries+ then throw $ UnexpectedResponse $ concat+ ["Posted ", show (length queries), " queries, but got ", show (length postResults), " results"]+ else return postResults+ Left resp ->+ if redirect+ then case find isLocation (rspHeaders resp) of+ Nothing -> throwIO $ FailedRedirection resp+ Just (Header _ q') -> do+ putStrLn $ "Rqlite Warning: Redirected to " ++ q'+ go (n + 1) q' (resp : acc)+ else throwIO $ HttpRedirect resp+ go 0 (mkPostRequest host) []++mkPostRequest :: String -> String+mkPostRequest host = "http://" ++ host ++ "/db/execute?pretty"++-- | This can be used to insert, create, delete a table..+postQuery :: Bool -> String -> String -> IO PostResult+postQuery redirect host body = head <$>+ postQueries redirect host [body]++getLastInsertId :: String -> [PostResult]+getLastInsertId str = case eitherDecodeStrict $ Char8.pack $ str of+ Left e -> throw $ UnexpectedResponse $ concat+ ["Got ", e, " while trying to decode ", str, " as PostResult"]+ Right (RQResults res) -> res+ Right (RQLeaderError err) -> throw $ LeadershipLost err++-- Get Requests --++data GetResult a =+ GetResult [a]+ | GetError String+ deriving (Show, Read, Generic)++data Level = None | Weak | Strong+ deriving (Show, Eq, Generic)++instance FromJSON a => FromJSON (GetResult a) where+ parseJSON j = do+ Object o <- parseJSON j+ case M.toList (o :: Object) of+ [("values", v), ("types", _), ("columns", _)] ->+ GetResult <$> parseJSON v+ [("types", _), ("columns", _)] ->+ return $ GetResult [] -- when there is no element+ [("error", String str)] ->+ return $ GetError $ Text.unpack str+ _ -> throw $ UnexpectedResponse $ concat+ ["Failed to decode ", show j, " as GetResult"]++mkQuery :: String -> Maybe Level -> String -> String+mkQuery host level q = concat+ [ "http://"+ , host+ , "/db/query?"+ , encodeLevel level+ , "pretty&q="+ , urlEncode q+ ]++-- | This can be used to query a table.+getQuery :: forall a. FromJSON a => Maybe Level -> String -> Bool -> String -> IO (GetResult a)+getQuery level host redirect q = go 0 (mkQuery host level q) []+ where+ go :: Int -> String -> [Response String] -> IO (GetResult a)+ go 5 _ acc = throwIO $ MaxNumberOfRedirections $ reverse acc+ go n query acc = do+ let http = simpleHTTP $ getRequest query+ mResp <- if redirect+ then reifyRed http+ else Right <$> reify http+ case mResp of+ Right respBody ->+ case eitherDecodeStrict $ Char8.pack respBody of+ Left e -> throwIO $ UnexpectedResponse $ concat+ ["Got ", e, " while trying to decode ", respBody, " as GetResult"]+ Right (RQResults res) -> return $ head $ res+ Right (RQLeaderError err) -> throwIO $ LeadershipLost err+ Left resp -> do+ case find isLocation (rspHeaders resp) of+ Nothing -> throwIO $ FailedRedirection resp+ Just (Header _ q') -> do+ putStrLn $ "Rqlite Warning: Redirected to " ++ q'+ go (n + 1) q' (resp : acc)++isLocation :: Header -> Bool+isLocation (Header HdrLocation _) = True+isLocation _ = False++encodeLevel :: Maybe Level -> String+encodeLevel Nothing = ""+encodeLevel (Just None) = "level=none&"+encodeLevel (Just Weak) = "level=weak&"+encodeLevel (Just Strong) = "level=strong&"++-- Exeptions handling++reify ::IO (Result (Response String)) -> IO String+reify = reifyHTTPErrors . reifyStreamErrors . reifyNoSuchThing++-- | Like reify, but returns Left for Redirect errors, instead of throwing them.+reifyRed :: IO (Result (Response String)) -> IO (Either (Response String) String)+reifyRed = reifyHTTPErrorsRed . reifyStreamErrors . reifyNoSuchThing++reifyStreamErrors :: IO (Result a) -> IO a+reifyStreamErrors action = do+ res <- action+ case res of+ Left err -> throwIO $ StreamError err+ Right a -> return a++-- | Like reifyHTTPErrors, but returns Left for Redirect errors, instead of throwing them.+reifyHTTPErrorsRed :: IO (Response String) -> IO (Either (Response String) String)+reifyHTTPErrorsRed action = do+ resp <-action+ case rspCode resp of+ (2,0,0) -> return $ Right $ rspBody resp+ (3,_,_) -> return $ Left resp+ _ -> throwIO $ HttpError $ resp++reifyHTTPErrors :: IO (Response String) -> IO String+reifyHTTPErrors action = do+ mresp <- reifyHTTPErrorsRed action+ case mresp of+ Left resp -> throwIO $ HttpRedirect resp+ Right str -> return str++reifyNoSuchThing :: IO a -> IO a+reifyNoSuchThing action = do+ a <- try action+ case a of+ Right a' -> return a'+ Left (e :: IOError) | ioe_type e == NoSuchThing -> throwIO $ NodeUnreachable e 1+ Left e -> throwIO e++data RQliteError =+ NodeUnreachable IOError Int -- Int here indicates number of trials we did.+ | StreamError ConnError+ | HttpError (Response String) -- Does the user really need the whole response here?+ | HttpRedirect (Response String)+ -- since RQlite is a distributed db, redirections to the leader+ -- deserve a different constructor, even though technically it+ -- is just another http error code.+ | MaxNumberOfRedirections [Response String]+ | FailedRedirection (Response String)+ | LeadershipLost Text+ | UnexpectedResponse String+ deriving (Show, Typeable, Exception)
+ src/Rqlite/Status.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Rqlite.Status+ ( RQStatus (..)+ , getLeader+ , retryUntilAlive+ , queryStatus+ ) where++import Control.Concurrent (threadDelay)+import Control.Exception+import Data.Aeson hiding (Result)+import qualified Data.ByteString.Char8 as C8+import GHC.Generics+import Network.HTTP hiding (host)++import Rqlite++-- This module provides support for requesting the status of a node+-- The actual status has many more info than what @RQStatus@ contains.++queryStatus :: String -> IO RQStatus+queryStatus host = do+ resp <- reify $ simpleHTTP $ getRequest $ concat+ [ "http://"+ , host+ , "/status?pretty"+ ]+ case eitherDecodeStrict $ C8.pack $ resp of+ Left e -> throwIO $ UnexpectedResponse $ concat+ ["Got ", e, " while trying to decode ", resp, " as PostResult"]+ Right st -> return st++data RQState = Leader | Follower | UnknownState+ deriving (Show, Eq, Generic)++readState :: String -> RQState+readState "Leader" = Leader+readState "Follower" = Follower+readState _ = UnknownState++-- | A subset of the status that a node reports.+data RQStatus = RQStatus {+ path :: String+ , leader :: Maybe String+ , peers :: [String]+ , state :: RQState+ , fk_constraints :: Bool+ } deriving (Show, Eq, Generic)++instance FromJSON RQStatus where+ parseJSON j = do+ Object o <- parseJSON j+ Object store <- o .: "store"+ pth <- store .: "dir"+ ldr <- store .: "leader"+ let mLeader = if ldr == "" then Nothing else Just ldr+ prs :: [String] <- store .: "peers"+ sqliteInfo <- store .: "sqlite3"+ raft <- store .: "raft"+ stStr <- raft .: "state"+ let st = readState stStr+ fk' :: String <- sqliteInfo .: "fk_constraints"+ let fk = fk' /= "disabled"+ return $ RQStatus pth mLeader prs st fk++getLeader :: String -> IO (Maybe String)+getLeader host = do+ mstatus <- queryStatus host+ return $ leader mstatus++-- | This can be used to make sure that a node is alive, before starting to query it.+retryUntilAlive :: String -> IO ()+retryUntilAlive host = go 40+ where+ go :: Int -> IO ()+ go n = do+ mStatus <- try $ queryStatus host+ case mStatus of+ Right _ -> return ()+ Left (NodeUnreachable e _) -> do+ threadDelay 500000+ if n > 0 then go $ n - 1+ else throwIO $ NodeUnreachable e 40+ Left e -> throwIO e