    --
    -- | 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 a. a -> IO a
    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
            conn <- QueryConfig -> IO DictConnection
    openDictConnection QueryConfig
    config
            result <- queryDict conn dictnm query
            closeDictConnection conn
            return result

    openDictConnection :: QueryConfig -> IO DictConnection
    openDictConnection :: QueryConfig -> IO DictConnection
    openDictConnection QueryConfig
    config = do
        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)
        hSetBuffering hDictServer LineBuffering
        _ <- readResponseLine hDictServer -- ignore response
        return 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
        _ <- DictConnection -> IO String
    readResponseLine DictConnection
    conn -- ignore response
        hClose 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)
        response <- DictConnection -> IO String
    readResponseLine DictConnection
    conn
        case response of
            Char
    '1':Char
    '5':String
    _     -> IO [String]
    readDefinition IO [String] -> ([String] -> IO LookupResult) -> IO LookupResult
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= LookupResult -> IO LookupResult
    forall a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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
            line <- DictConnection -> IO String
    readResponseLine DictConnection
    conn
            case line of
                Char
    '2':Char
    '5':Char
    '0':String
    _ -> [String] -> IO [String]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                String
    _             -> IO [String]
    readDefinition IO [String] -> ([String] -> IO [String]) -> IO [String]
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= [String] -> IO [String]
    forall a. a -> IO a
    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
        line <- DictConnection -> IO String
    hGetLine DictConnection
    conn
        return (filter (/='\r') 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 :: forall a. [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")