diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hs-rqlite + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hs-rqlite.cabal b/hs-rqlite.cabal new file mode 100644 --- /dev/null +++ b/hs-rqlite.cabal @@ -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 +bug-reports: https://github.com/kderme/hs-rqlite/issues +license: BSD-3-Clause +license-file: LICENSE +author: Konstantinos Dermentzis +maintainer: Konstantinos Dermentzis +copyright: Konstantinos Dermentzis +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 diff --git a/src/Rqlite.hs b/src/Rqlite.hs new file mode 100644 --- /dev/null +++ b/src/Rqlite.hs @@ -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) diff --git a/src/Rqlite/Status.hs b/src/Rqlite/Status.hs new file mode 100644 --- /dev/null +++ b/src/Rqlite/Status.hs @@ -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