--
-- | 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 =
    (SomeException -> IO LookupResult)
-> IO LookupResult -> IO LookupResult
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\SomeException
e -> (LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupResult -> IO LookupResult)
-> LookupResult -> IO LookupResult
forall a b. (a -> b) -> a -> b
$ String -> LookupResult
forall a b. a -> Either a b
Left (SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)))) (IO LookupResult -> IO LookupResult)
-> IO LookupResult -> IO LookupResult
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
        LookupResult -> IO LookupResult
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 (Int -> PortNumber) -> Int -> PortNumber
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
    DictConnection -> IO DictConnection
forall (m :: * -> *) a. Monad m => a -> m a
return DictConnection
hDictServer
    where
    mkPortNumber :: Int -> PortNumber
mkPortNumber = Int -> PortNumber
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 IO [String] -> ([String] -> IO LookupResult) -> IO LookupResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupResult -> IO LookupResult)
-> ([String] -> LookupResult) -> [String] -> IO LookupResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> LookupResult
forall a. [String] -> Either a String
formatDefinition
        Char
'5':Char
'5':Char
'2':String
_ -> LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupResult -> IO LookupResult)
-> LookupResult -> IO LookupResult
forall a b. (a -> b) -> a -> b
$ String -> LookupResult
forall a b. b -> Either a b
Right (String
"No match for \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
query String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\".\n")
        Char
'5':String
_         -> LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupResult -> IO LookupResult)
-> LookupResult -> IO LookupResult
forall a b. (a -> b) -> a -> b
$ String -> LookupResult
forall a b. a -> Either a b
Left String
response -- error response
        String
_             -> LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupResult -> IO LookupResult)
-> LookupResult -> IO LookupResult
forall a b. (a -> b) -> a -> b
$ String -> LookupResult
forall a b. a -> Either a b
Left (String
"Bogus response: " String -> String -> String
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
_ -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            String
_             -> IO [String]
readDefinition IO [String] -> ([String] -> IO [String]) -> IO [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String])
-> ([String] -> [String]) -> [String] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
lineString -> [String] -> [String]
forall a. a -> [a] -> [a]
:)

    formatDefinition :: [String] -> Either a String
formatDefinition = String -> Either a String
forall a b. b -> Either a b
Right (String -> Either a String)
-> ([String] -> String) -> [String] -> Either a String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String]) -> [String] -> [String]
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
"***" String -> 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
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case DictCommand
cmd of
        DictCommand
Quit -> String
"QUIT"
        Define String
db String
target -> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
join String
" " [String
"DEFINE", String
db, String
target]

join :: [a] -> [[a]] -> [a]
join :: [a] -> [[a]] -> [a]
join = ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat([[a]] -> [a]) -> ([[a]] -> [[a]]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([[a]] -> [[a]]) -> [[a]] -> [a])
-> ([a] -> [[a]] -> [[a]]) -> [a] -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]] -> [[a]]
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r\n")