{-# LANGUAGE FlexibleContexts, OverloadedStrings, LambdaCase #-}
module HQuery (hquery
,getSciDbVersion
,mkGlobalManagerEnv
,runQueries
,unsafeRunQuery
) where
import Control.Monad (unless,when)
import Control.Monad.Catch (try,MonadCatch,MonadThrow)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader,ReaderT,runReaderT,ask)
import Control.Monad.State (StateT,evalStateT,liftIO,get,put)
import Control.Monad.State.Class (MonadState)
import Control.Monad.Trans (lift)
import Data.Char (toLower)
import Data.List (intercalate)
import Data.Maybe (isNothing,isJust,fromJust,fromMaybe)
import Data.X509.CertificateStore (readCertificateStore)
import Network.Socket (withSocketsDo)
import Network.Connection (TLSSettings(..))
import Network.HTTP.Base (urlEncode,urlDecode)
import Network.HTTP.Client (defaultManagerSettings,requestHeaders,defaultRequest
,RequestBody,streamFile,requestBody,method,Request)
import Network.HTTP.Client.TLS (getGlobalManager,setGlobalManager,applyDigestAuth)
import Network.HTTP.Simple (parseRequestThrow,httpLBS,setRequestManager)
import Network.HTTP.Conduit (HttpException(..),HttpExceptionContent(..),Response(..)
,managerResponseTimeout,responseTimeoutNone,newManager
,mkManagerSettings)
import Network.HTTP.Types.Status (Status(..))
import Safe (tailSafe,headMay)
import System.Console.Haskeline (runInputT,defaultSettings,getInputLine,historyFile
,withInterrupt,handleInterrupt,outputStrLn)
import System.Console.Terminal.Size (Window(..),size)
import System.Exit (exitWith,ExitCode(..))
import System.IO (stderr,stdin,hPutStrLn,hReady,getContents)
import qualified Data.Text.Lazy.Encoding as L (decodeUtf8)
import qualified Data.Text.Lazy as L (unpack)
import qualified Data.ByteString.Char8 as C (pack,unpack)
import qualified Network.HTTP.Client as H (Request(..))
import Environment (Environment(certStore,defFetch,defFormat,defNumber
,defReadingLines,defPrefix,digestAuth
,digestHeaders,file,history,host,insecure
,operands,password,port,protocol,sciDbVersion
,scidbAuth,username,verbose,waitOnStdIn)
,defaultEnv,maybePort,Verbosity(..))
import ErrM (Err(..))
import Interpreter (Results(..),interpret)
import Utils (strip,wrap,nolines,cleanDoubleQuotes,replace,toSingleQuotedStr
,escapeSingleQuotes,toSingleQuotedStr,checkMajorVersion)
import UtilsUnsafe (managerSettings,valid,VALID(..))
data Param =
Param {session :: String
,number :: String
,fetch :: Bool
,format :: String
,readingLines:: Bool
,prefix :: String
,fileBody :: Maybe RequestBody
}
defaultParam = Param {session = ""
,number = defNumber defaultEnv
,fetch = fromJust $ defFetch defaultEnv
,format = defFormat defaultEnv
,readingLines = fromJust $ defReadingLines defaultEnv
,prefix = ""
,fileBody = Nothing
}
initParam :: StateT Param (ReaderT Environment IO) ()
initParam = do e <- ask
p <- get
put p{number = defNumber e
,fetch = fromJust $ defFetch e
,format = defFormat e
,readingLines = fromJust $ defReadingLines e
,prefix = defPrefix e
}
getSciDbVersion :: Environment -> IO String
getSciDbVersion e = withSocketsDo (runReaderT (evalStateT fetchVersion defaultParam{number="0"}) e)
where
fetchVersion = do e <- ask
let url = urlPrefix e ++ "/version"
fetchURL (verbose e) url
mkGlobalManagerEnv :: Environment -> IO (Maybe Environment)
mkGlobalManagerEnv env =
do mstore <- readCertificateStore (certStore env)
let defSettings = defaultManagerSettings
tlsSettings = mkManagerSettings (TLSSettingsSimple True False False) Nothing
caStore = fromJust mstore
caSettings = managerSettings caStore
s <- if protocol env /= "https"
then return $ Just defSettings
else if insecure env
then return $ Just tlsSettings
else if isJust mstore
then return $ Just caSettings
else return Nothing
if isNothing s
then return Nothing
else do let s' = fromJust s
manager <- newManager s'{managerResponseTimeout=responseTimeoutNone}
liftIO $ setGlobalManager manager
request <- maybeSetDigestAuth' env
let env' = env{digestHeaders = maybe [] requestHeaders request}
if digestAuth env
then do v <- getSciDbVersion env'
return $ Just env'{sciDbVersion=v}
else do v <- getSciDbVersion env
return $ Just env{sciDbVersion=v}
where
maybeSetDigestAuth' =
runReaderT (do env <- ask
maybeSetDigestAuth defaultRequest{H.host = C.pack $ host env
,H.port = read $ maybePort env :: Int
,H.secure = protocol env == "https"
}
)
maybeSetDigestAuth :: (MonadReader Environment m, MonadIO m, MonadThrow n) => Request -> m (n Request)
maybeSetDigestAuth r =
do e <- ask
m <- liftIO getGlobalManager
let user = C.pack $ username e
pass = C.pack $ password e
if digestAuth e
then liftIO $ applyDigestAuth user pass r{H.secure = protocol e == "https"} m
else return $ return r
unsafeRunQuery :: Environment -> String -> IO String
unsafeRunQuery e s =
withSocketsDo (runReaderT (evalStateT _executeQuery defaultParam) e)
where _executeQuery = do initParam
p <- get
executeAndGet (fetch p) s
runQueries :: Environment -> String -> IO [Err String]
runQueries e s =
withSocketsDo (runReaderT (evalStateT (executeQueries s) defaultParam) e)
executeQueries :: String -> StateT Param (ReaderT Environment IO) [Err String]
executeQueries s =
do initParam
case interpret s of
Ok rs -> filter (\case Ok "" -> False; _ -> True) <$> mapM executeResult rs
Bad s' -> return [Bad s']
data ExitOrDont = ExitOnBad | DontExitOnBad deriving Eq
hquery :: Environment -> IO ()
hquery e = withSocketsDo (runReaderT (evalStateT _hquery defaultParam) e)
where _hquery =
do initParam
e <- ask
r <- liftIO $ hReady stdin
if null (operands e) && null (file e) && not (waitOnStdIn e) && not r
then do liftIO $ putStrLn ("SciDB version "++sciDbVersion e)
executeQuery DontExitOnBad "list('instances');"
iQuery
else do c <- liftIO $ if r || waitOnStdIn e then getContents else return ""
f <- liftIO $ (if null (file e) then return else readFile) (file e)
let a = intercalate "\n" ("":(nolines <$> operands e))
executeQuery ExitOnBad (c ++ f ++ a)
iQuery =
do e <- ask
p <- get
liftIO $ runInputT defaultSettings{historyFile = Just (history e)} (loop e p)
loop e p = withInterrupt (_loop p)
where
_loop p = handleInterrupt (outputStrLn "^C" >> _loop p) $
do minput <- fmap strip <$> getInput (prompt p ++ " ")
case minput of
Nothing -> return ()
Just "" -> _loop p
Just q -> do p' <- lift $ runReaderT (evalStateT (do executeQuery DontExitOnBad q
get
) p) e
_loop p'
getInput p = getInput' p False ""
where getInput' p insideQuote q =
do mi <- getInputLine p
case mi of
Nothing -> return Nothing
Just "" -> return $ Just ""
Just l -> processInput insideQuote q l
processInput insideQuote q [] = getInput' "Con> " insideQuote (q++"\n")
processInput insideQuote q (c:cs) =
case c of
'\\' -> case headMay cs of
Nothing -> getInput' "Con> " insideQuote (q++[c,'\n'])
Just hd -> processInput insideQuote (q++[c,hd]) (tailSafe cs)
'\'' -> processInput (toggle insideQuote) (q++[c]) cs where toggle=not
';' | insideQuote -> processInput insideQuote (q ++ [c]) cs
| null (strip cs) -> return $ Just (q ++ [c] ++ cs ++ "\n")
| otherwise -> processInput insideQuote (q ++ [c]) cs
_ -> processInput insideQuote (q++[c]) cs
prompt param = (if not (readingLines param) && fetch param then "Bytes" else show (fetch param))
++"/"++format param++"/"++number param
++(if null (prefix param) then "?" else "p")
executeQuery f s =
case interpret s of
Ok rs -> let n = length rs
bads = findBads rs
in if null bads
then mapM_ executeResult' rs
else liftIO $
mapM_ (\(i,r) -> putStderr ("Query "++show i++" of "++show n++": ") (show r))
bads
Bad s -> liftIO (putStderr "Input " s >> if f == DontExitOnBad then return () else exit 12)
findBads rs = filter (\(_,r) -> case r of BadNesting _ -> True ; _ -> False) $ zip [1..] rs
executeResult' r = do err <- executeResult r
liftIO $ case err of
Bad s -> putStderr "Input " s
Ok s -> putStr s
executeResult :: Results -> StateT Param (ReaderT Environment IO) (Err String)
executeResult r =
case r of
BadNesting s -> return $ Bad ("bad nesting " ++ toSingleQuotedStr s)
No s -> do executeAndGet False s
return $ Ok ""
Yes s -> do p <- get
if fetch p
then Ok <$> executeAndGet True s
else executeResult (No s)
Upload (q,ss)-> executeUpload q ss
Unknown s -> executeResult (Yes s)
_ -> do executeCommand r
return $ Ok ""
where
executeUpload s [] = do let q = s++";"
(intercalate "\n" <$>) . sequence <$> executeQueries q
executeUpload s (p:ps) =
do let fp = fst p
needle = snd p
b <- liftIO $ valid READABLE fp
if b
then do fetchSession
putVerbose "filepath to upload=" fp
u <- toSingleQuotedStr <$> uploadFile fp
putVerbose "uploaded filepath=" u
p <- get
err <- executeUpload (replace needle u s) ps
put p
releaseSession
return err
else return $ Bad ("Bad filepath '"++escapeSingleQuotes fp++"'")
uploadFile fp = do e <- ask
p <- get
rb <- liftIO $ streamFile fp
put p{fileBody=Just rb}
let url = urlPrefix e ++ "/upload?id=" ++ session p
fetchURL (verbose e) url
executeCommand :: (MonadIO m, MonadState Param m) => Results -> m ()
executeCommand r =
case r of
Command s -> case fmap toLower s of
"quit" -> exit 0
"exit" -> exit 0
"funs" -> liftIO $ putStrLn ( "exit - exit or quit interpreter"
++ "\nfuns - list interpreter functions"
++ "\nquit - quit or exit interpreter"
++ "\nupload - upload a file and run a query using it"
++ "\nvars - list interpreter variables and values"
)
"vars" -> do p <- get
liftIO $ putStrLn ( "fetch = " ++ show (fetch p)
++ "\nreadinglines = " ++ show (readingLines p)
++ "\nformat = " ++ format p
++ "\nnumber = " ++ number p
++ "\nprefix = " ++ prefix p
)
_ -> liftIO $ putStderr "Ignored unknown command: " s
Fetch mb -> unless (isNothing mb) $ do p <- get
put $ p{fetch=fromJust mb}
Format ms -> unless (isNothing ms) $ do p <- get
put $ p{format=fromJust ms}
Lines mi -> unless (isNothing mi) $ do p <- get
put $ p{number=show$fromJust mi}
ReadingLines mb -> unless (isNothing mb) $ do p <- get
put p{readingLines=fromJust mb}
Prefix s -> do p <- get
put p{prefix=s}
executeAndGet :: Bool -> String -> StateT Param (ReaderT Environment IO) String
executeAndGet f s =
do fetchSession
e <- ask
p <- get
let url = urlPrefix e ++ "/execute_query?id=" ++ session p ++ addPrefix p ++ "&query=" ++ urlEncode s
++ (if f then "&save=" ++ urlEncode (format p) else "") ++ addAuthCode e
putVerbose "execute_query=" s
fetchURL (verbose e) url
d <- if f then readData else return ""
releaseSession
return d
where
addPrefix p = if null (prefix p) then "" else "&prefix=" ++ prefix p
readData =
do e <- ask
p <- get
let url = urlPrefix e ++ (if readingLines p then "/read_lines" else "/read_bytes")
++ "?id=" ++ session p
++ "&n=" ++ (if readingLines p then number p else "0")
v = quietIfDef (verbose e)
fetchURL v url
fetchURL :: (MonadReader Environment m, MonadState Param m, MonadIO m, MonadCatch m)
=> Verbosity -> String -> m String
fetchURL v s =
do env <- ask
r <- try (continueHttp s)
case r of
Left e -> do let prefix = "SciDB " ++ sciDbVersion env ++ " URL exception\n "
when (v > Verbose0) $ liftIO $ putHttpException prefix s e
return ""
Right b -> do when (v > Verbose1) $ liftIO $ putStderr "URL=" s
return $ L.unpack $ L.decodeUtf8 b
where continueHttp s =
do e <- ask
p <- get
request <- parseRequestThrow s
let request'=request{requestHeaders=digestHeaders e++requestHeaders request}
response <- if isNothing (fileBody p)
then httpLBS request'
else do
mrequest <- maybeSetDigestAuth request{method="POST",requestBody=fromJust$fileBody p}
httpLBS $ fromMaybe request' mrequest
return (responseBody response)
putHttpException prefix s e =
do putStderr prefix s
putStderr (tailSafe $ dropWhile (/='\n') prefix) (urlDecode s)
case e of
InvalidUrlException url reason -> putStderr (url ++ ": ") reason
HttpExceptionRequest req e ->
do w <- maybe consoleWidth width <$> size
case e of
StatusCodeException responseBody s ->
do let status = responseStatus responseBody
putStderr "HTTP code = " $ show $ statusCode status
let m = statusMessage status
putStderr " message = " $ C.unpack m
putStderr response_ $ format w i0 $ C.unpack s
when (unauthorized == m) (exit 10)
when (noSciDBconnect == s) (exit 11)
TooManyRedirects _ -> putStderr "TooManyRedirects" "" >> exit 8
OverlongHeaders -> putStderr "OverlongHeaders" "" >> exit 8
ResponseTimeout -> putStderr "ResponseTimeout" ""
ConnectionTimeout -> putStderr "ConnectionTimeout" ""
ConnectionFailure _ -> putStderr "ConnectionFailure" ""
InvalidStatusLine _ -> putStderr "InvalidStatusLine" "" >> exit 8
InvalidHeader _ -> putStderr "InvalidHeader" "" >> exit 8
InvalidRequestHeader _ -> putStderr "InvalidRequestHeader" "" >> exit 8
InternalException _ -> putStderr internalException (format w i1 $ cleanDoubleQuotes $ show e) >> exit 8
ProxyConnectException{} -> putStderr "ProxyConnectException" "" >> exit 8
NoResponseDataReceived -> putStderr "NoResponseDataReceived" ""
TlsNotSupported -> putStderr "TlsNotSupported" "" >> exit 8
WrongRequestBodyStreamSize _ _ -> putStderr "WrongRequestBodyStreamSize" "" >> exit 8
ResponseBodyTooShort _ _ -> putStderr "ResponseBodyTooShort" "" >> exit 8
InvalidChunkHeaders -> putStderr "InvalidChunkHeaders" "" >> exit 8
IncompleteHeaders -> putStderr "IncompleteHeaders" "" >> exit 8
InvalidDestinationHost _ -> putStderr "InvalidDestinationHost" "" >> exit 8
HttpZlibException _ -> putStderr "HttpZlibException" ""
InvalidProxyEnvironmentVariable _ _ -> putStderr "InvalidProxyEnvironmentVariable" "" >> exit 8
ConnectionClosed -> putStderr "ConnectionClosed" ""
InvalidProxySettings _ -> putStderr "InvalidProxySettings" "" >> exit 8
where response_ = " response = "
internalException = "InternalException: " :: String
i0 = length response_
i1 = length internalException
unauthorized = C.pack "Unauthorized"
noSciDBconnect = C.pack "Could not connect to SciDB"
consoleWidth = 80
format w i s = (intercalate "\n" . indent) ls
where ls = (concatMap (wrap l) . lines) s
l = max consoleWidth w - i
indent [] = []
indent ls = hd:((ss++) <$> tl)
where hd = head ls
tl = tail ls
ss = replicate i ' '
fetchSession :: StateT Param (ReaderT Environment IO) ()
fetchSession =
do e <- ask
p <- get
let url = urlPrefix e ++ "/new_session" ++ addAuthCode e
s <- fetchURL (verbose e) url
put p{session = strip s}
p' <- get
putVerbose "session=" (session p')
where addAuthCode e = if scidbAuth e && checkMajorVersion (>=19) (sciDbVersion e)
then "?user=" ++ username e ++ "&password=" ++ password e
else ""
releaseSession :: StateT Param (ReaderT Environment IO) ()
releaseSession =
do e <- ask
p <- get
let url = urlPrefix e ++ "/release_session?id=" ++ session p
v = quietIfDef (verbose e)
s <- fetchURL v url
putVerbose "release_session=" (session p ++ s)
cancelSession :: StateT Param (ReaderT Environment IO) ()
cancelSession =
do e <- ask
p <- get
let url = urlPrefix e ++ "/cancel?id=" ++ session p ++ addAuthCode e
v = quietIfDef (verbose e)
s <- fetchURL v url
putVerbose "cancel_session=" (session p ++ s)
addAuthCode :: Environment -> String
addAuthCode e = if scidbAuth e && checkMajorVersion (18>=) (sciDbVersion e)
then "&user=" ++ username e ++ "&password=" ++ password e
else ""
putVerbose :: (MonadReader Environment m, MonadIO m) => String -> String -> m ()
putVerbose s t = do e <- ask
when (verbose e > VerboseDef) (putStderr s t)
quietIfDef :: Verbosity -> Verbosity
quietIfDef v = if v /= VerboseDef then v else Verbose0
urlPrefix :: Environment -> String
urlPrefix env = protocol' ++ "://" ++ host' ++ ":" ++ port'
where protocol' = protocol env
host' = host env
port' = maybePort env
putStderr :: MonadIO m => String -> String -> m ()
putStderr s t = unless (null t) $ liftIO $ hPutStrLn stderr (s++t)
exit :: MonadIO m => Int -> m a
exit i = liftIO $ exitWith $ if i == 0 then ExitSuccess else ExitFailure i