module Hunt.Interpreter.Command
( Command (..)
, StatusCmd (..)
, CmdResult (..)
, CmdError (..)
, CmdRes (..)
, toBasicCommand
)
where
import Control.Applicative
import Control.Monad (mzero)
import Control.Monad.Error (Error (..))
import Control.DeepSeq
import Data.Aeson
import Data.List
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Hunt.Common.ApiDocument
import Hunt.Common.BasicTypes
import Hunt.Index.Schema
import Hunt.Query.Language.Grammar (Query (..))
import Hunt.Query.Intermediate (RankedDoc)
import Hunt.Interpreter.BasicCommand (BasicCommand, StatusCmd (..))
import qualified Hunt.Interpreter.BasicCommand as Cmd
import Hunt.Utility.Log
data Command
= Search { icQuery :: Query
, icOffsetSR :: Int
, icMaxSR :: Int
, icWeight :: Bool
, icFields :: Maybe [Text]
}
| Completion { icPrefixCR :: Query
, icMaxCR :: Int
}
| Select { icQuery :: Query }
| Insert { icDoc :: ApiDocument }
| Update { icDoc :: ApiDocument }
| Delete { icUri :: URI }
| DeleteByQuery { icQueryD :: Query }
| InsertContext { icIContext :: Context
, icSchema :: ContextSchema
}
| DeleteContext { icDContext :: Context }
| LoadIx { icPath :: FilePath }
| StoreIx { icPath :: FilePath }
| Status { icStatus :: StatusCmd }
| Sequence { icCmdSeq :: [Command] }
| NOOP
deriving (Show)
data CmdResult
= ResOK
| ResSearch { crRes :: LimitedResult RankedDoc }
| ResCompletion { crWords :: [(Text, [Text])] }
| ResSuggestion { crSugg :: [(Text, Score)] }
| ResGeneric { crGen :: Value }
deriving (Show, Eq)
instance NFData CmdResult where
rnf (ResSearch r) = r `seq` ()
rnf (ResCompletion c) = c `seq` ()
rnf (ResSuggestion s) = s `seq` ()
rnf _ = ()
data CmdError
= ResError
{ ceCode :: Int
, ceMsg :: Text
} deriving (Show)
instance NFData CmdError where
rnf (ResError i t) = t `seq` i `seq` ()
newtype CmdRes a = CmdRes { unCmdRes :: a }
deriving (Show)
instance (FromJSON a) => FromJSON (CmdRes a) where
parseJSON (Object o) = do
c <- o .: "code"
case (c :: Int) of
0 -> CmdRes <$> o .: "msg"
_ -> mzero
parseJSON _ = mzero
instance LogShow Command where
logShow (Insert doc) = "Insert {icDoc = " ++ logShow doc ++ "\", ..}"
logShow (Update doc) = "Update {icDoc = " ++ logShow doc ++ "\", ..}"
logShow (Sequence _) = "Sequence"
logShow o = show o
instance ToJSON Command where
toJSON o = case o of
Search q ofs mx wght sel
-> object . cmd "search" $
[ "query" .= q
, "offset" .= ofs
, "max" .= mx
]
++
( if wght
then [ "weight" .= wght ]
else []
)
++
maybe [] (\ fs -> [ "fields" .= fs ]) sel
Completion s mx -> object . cmd "completion" $ [ "text" .= s, "max" .= mx ]
Select q -> object . cmd "select" $ [ "query" .= q ]
Insert d -> object . cmd "insert" $ [ "document" .= d ]
Update d -> object . cmd "update" $ [ "document" .= d ]
Delete u -> object . cmd "delete" $ [ "uri" .= u ]
DeleteByQuery q -> object . cmd "delete-by-query"$ [ "query" .= q ]
InsertContext c s -> object . cmd "insert-context" $ [ "context" .= c, "schema" .= s ]
DeleteContext c -> object . cmd "delete-context" $ [ "context" .= c ]
LoadIx f -> object . cmd "load" $ [ "path" .= f ]
StoreIx f -> object . cmd "store" $ [ "path" .= f ]
Status sc -> object . cmd "status" $ [ "status" .= sc ]
NOOP -> object . cmd "noop" $ []
Sequence cs -> toJSON cs
where
cmd c = (:) ("cmd" .= (c :: Text))
instance FromJSON Command where
parseJSON (Object o) = do
c <- o .: "cmd"
case (c :: Text) of
"search" -> Search <$> o .: "query"
<*> o .:? "offset" .!= 0
<*> o .:? "max" .!= (1)
<*> o .:? "weight" .!= False
<*> o .:? "fields"
"completion" -> Completion <$> o .: "text"
<*> o .: "max"
"select" -> Select <$> o .: "query"
"insert" -> Insert <$> o .: "document"
"update" -> Update <$> o .: "document"
"delete" -> Delete <$> o .: "uri"
"delete-by-query"-> DeleteByQuery <$> o .: "query"
"insert-context" -> InsertContext <$> o .: "context"
<*> o .: "schema"
"delete-context" -> DeleteContext <$> o .: "context"
"load" -> LoadIx <$> o .: "path"
"store" -> StoreIx <$> o .: "path"
"noop" -> return NOOP
"status" -> Status <$> o .: "status"
_ -> mzero
parseJSON v = Sequence <$> parseJSON v
instance ToJSON CmdResult where
toJSON o = case o of
ResOK -> object . code 0 $ []
ResSearch r -> object . code 0 $ [ "res" .= r ]
ResCompletion w -> object . code 0 $ [ "res" .= w ]
ResSuggestion r -> object . code 0 $ [ "res" .= r ]
ResGeneric v -> object . code 0 $ [ "res" .= v ]
where
code i = (:) ("code" .= (i :: Int))
instance Error CmdError where
strMsg s = ResError 500 . T.pack $ "internal server error: " ++ s
instance ToJSON CmdError where
toJSON (ResError c m) = object
[ "code" .= c
, "msg" .= m
]
instance FromJSON CmdError where
parseJSON (Object o) = ResError <$> o .: "code"
<*> o .: "msg"
parseJSON _ = mzero
toBasicCommand :: Command -> BasicCommand
toBasicCommand (Sequence cs) = Cmd.Sequence $ opt cs
where
opt :: [Command] -> [BasicCommand]
opt cs' = concatMap optGroup $ groupBy equalHeads cs'
optGroup :: [Command] -> [BasicCommand]
optGroup cs'@(Delete{}:_)
= [foldl (\(Cmd.DeleteDocs us) (Delete u)
-> Cmd.DeleteDocs (S.insert u us)) (Cmd.DeleteDocs S.empty) cs']
optGroup cs'@(Insert{}:_)
= [splitBatch maxBound $ foldl (\(Cmd.InsertList us) (Insert u)
-> Cmd.InsertList (u:us)) (Cmd.InsertList []) cs']
optGroup cs'@(Sequence{}:_)
= map toBasicCommand cs'
optGroup cs'
= map toBasicCommand cs'
equalHeads :: Command -> Command -> Bool
equalHeads Delete{} Delete{} = True
equalHeads Insert{} Insert{} = True
equalHeads Sequence{} Sequence{} = True
equalHeads _ _ = False
toBasicCommand (Delete u) = Cmd.DeleteDocs $ S.singleton u
toBasicCommand (DeleteByQuery q) = Cmd.DeleteByQuery q
toBasicCommand (Search a b c d e) = Cmd.Search a b c d e
toBasicCommand (Completion a b) = Cmd.Completion a b
toBasicCommand (Select a) = Cmd.Select a
toBasicCommand (Insert a) = Cmd.InsertList [a]
toBasicCommand (Update a) = Cmd.Update a
toBasicCommand (InsertContext a b) = Cmd.InsertContext a b
toBasicCommand (DeleteContext a) = Cmd.DeleteContext a
toBasicCommand (LoadIx a) = Cmd.LoadIx a
toBasicCommand (StoreIx a) = Cmd.StoreIx a
toBasicCommand (Status a) = Cmd.Status a
toBasicCommand (NOOP) = Cmd.NOOP
splitBatch :: Int -> BasicCommand -> BasicCommand
splitBatch n (Cmd.InsertList xs)
= Cmd.Sequence $ map Cmd.InsertList $ splitEvery n xs
splitBatch _ cmd
= cmd
splitEvery :: Int -> [a] -> [[a]]
splitEvery _ [] = []
splitEvery n list = first : splitEvery n rest
where
(first,rest) = splitAt n list