--
-- | DICT (RFC 2229) Lookup 
-- Tom Moertel <tom@moertel.com>
-- 
--Here's how you might write a program to query the Jargon database for
--the definition of "hacker" and then print the result:
--
-- >  main = doJargonLookup "hacker" >>= putStr
-- >
-- >  doJargonLookup :: String -> IO String
-- >  doJargonLookup query = do
-- >      result <- simpleDictLookup (QC "dict.org" 2628) "jargon" query 
-- >      return $ case result of
-- >          Left errorResult -> "ERROR: " ++ errorResult
-- >          Right dictResult -> dictResult
-- >
--
module Lambdabot.Plugin.Reference.Dict.DictLookup ( simpleDictLookup, QueryConfig(..), LookupResult) where

import Data.List
import System.IO
import Control.Exception (SomeException, handle)
import Network.Socket
import Lambdabot.Util.Network

data QueryConfig    = QC { QueryConfig -> String
host :: String, QueryConfig -> Int
port :: Int }
type DictConnection = Handle
data DictCommand    = Quit | Define DictName String
type DictName       = String -- dict-db name | "!" 1st match | "*" all matches
type LookupResult   = Either String String -- Left <error> | Right <result>

simpleDictLookup :: QueryConfig -> DictName -> String -> IO LookupResult
simpleDictLookup :: QueryConfig -> String -> String -> IO LookupResult
simpleDictLookup QueryConfig
config String
dictnm String
query =
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\SomeException
e -> (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (SomeException
e :: SomeException)))) forall a b. (a -> b) -> a -> b
$ do
        DictConnection
conn <- QueryConfig -> IO DictConnection
openDictConnection QueryConfig
config
        LookupResult
result <- DictConnection -> String -> String -> IO LookupResult
queryDict DictConnection
conn String
dictnm String
query
        DictConnection -> IO ()
closeDictConnection DictConnection
conn
        forall (m :: * -> *) a. Monad m => a -> m a
return LookupResult
result

openDictConnection :: QueryConfig -> IO DictConnection
openDictConnection :: QueryConfig -> IO DictConnection
openDictConnection QueryConfig
config = do
    DictConnection
hDictServer <- String -> PortNumber -> IO DictConnection
connectTo' (QueryConfig -> String
host QueryConfig
config) (Int -> PortNumber
mkPortNumber forall a b. (a -> b) -> a -> b
$ QueryConfig -> Int
port QueryConfig
config)
    DictConnection -> BufferMode -> IO ()
hSetBuffering DictConnection
hDictServer BufferMode
LineBuffering
    String
_ <- DictConnection -> IO String
readResponseLine DictConnection
hDictServer -- ignore response
    forall (m :: * -> *) a. Monad m => a -> m a
return DictConnection
hDictServer
    where
    mkPortNumber :: Int -> PortNumber
mkPortNumber = forall a b. (Integral a, Num b) => a -> b
fromIntegral

closeDictConnection :: DictConnection -> IO ()
closeDictConnection :: DictConnection -> IO ()
closeDictConnection DictConnection
conn = do
    DictConnection -> DictCommand -> IO ()
sendCommand DictConnection
conn DictCommand
Quit
    String
_ <- DictConnection -> IO String
readResponseLine DictConnection
conn -- ignore response
    DictConnection -> IO ()
hClose DictConnection
conn

{-
queryAllDicts :: DictConnection -> String -> IO LookupResult
queryAllDicts = flip queryDict "*"
-}

queryDict :: DictConnection -> DictName -> String -> IO LookupResult
queryDict :: DictConnection -> String -> String -> IO LookupResult
queryDict DictConnection
conn String
dictnm String
query = do
    DictConnection -> DictCommand -> IO ()
sendCommand DictConnection
conn (String -> String -> DictCommand
Define String
dictnm String
query)
    String
response <- DictConnection -> IO String
readResponseLine DictConnection
conn
    case String
response of
        Char
'1':Char
'5':String
_     -> IO [String]
readDefinition forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [String] -> Either a String
formatDefinition
        Char
'5':Char
'5':Char
'2':String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (String
"No match for \"" forall a. [a] -> [a] -> [a]
++ String
query forall a. [a] -> [a] -> [a]
++ String
"\".\n")
        Char
'5':String
_         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
response -- error response
        String
_             -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (String
"Bogus response: " forall a. [a] -> [a] -> [a]
++ String
response)
            
    where

    readDefinition :: IO [String]
readDefinition = do
        String
line <- DictConnection -> IO String
readResponseLine DictConnection
conn
        case String
line of
            Char
'2':Char
'5':Char
'0':String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
            String
_             -> IO [String]
readDefinition forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
lineforall a. a -> [a] -> [a]
:)

    formatDefinition :: [String] -> Either a String
formatDefinition = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
formater

    formater :: String -> [String]
formater (Char
'1':Char
'5':Char
'1':String
rest) = [String
"", String
"***" forall a. [a] -> [a] -> [a]
++ String
rest]
    formater String
"."                = []
    formater String
line               = [String
line]


readResponseLine :: DictConnection -> IO String
readResponseLine :: DictConnection -> IO String
readResponseLine DictConnection
conn = do
    String
line <- DictConnection -> IO String
hGetLine DictConnection
conn
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Char
'\r') String
line)

sendCommand :: DictConnection -> DictCommand -> IO ()
sendCommand :: DictConnection -> DictCommand -> IO ()
sendCommand DictConnection
conn DictCommand
cmd =
    DictConnection -> String -> IO ()
hSendLine DictConnection
conn forall a b. (a -> b) -> a -> b
$ case DictCommand
cmd of
        DictCommand
Quit -> String
"QUIT"
        Define String
db String
target -> forall a. [a] -> [[a]] -> [a]
join String
" " [String
"DEFINE", String
db, String
target]

join :: [a] -> [[a]] -> [a]
join :: forall a. [a] -> [[a]] -> [a]
join = (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concatforall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse

hSendLine :: Handle -> String -> IO ()
hSendLine :: DictConnection -> String -> IO ()
hSendLine DictConnection
h String
line = DictConnection -> String -> IO ()
hPutStr DictConnection
h (String
line forall a. [a] -> [a] -> [a]
++ String
"\r\n")