{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
import System.Environment
import System.Posix.Files ( getFileStatus, fileMode )
import Data.Bits          ( (.&.) )
import Data.Text          ( Text )
import qualified Data.Text    as Text
import qualified Data.Text.IO as Text
import Control.Applicative
import Control.Monad
import Data.Maybe
import XMPPServer
import Data.Monoid

-- Transforms a string of form language[_territory][.codeset][@modifier]
-- typically used in LC_ locale variables into the BCP 47
-- language codes used in xml:lang attributes.
toBCP47 :: [Char] -> [Char]
toBCP47 lang = map hyphen $ takeWhile (/='.') lang
 where hyphen '_' = '-'
       hyphen  c  =  c


#if MIN_VERSION_base(4,6,0)
#else
lookupEnv k = fmap (lookup k) getEnvironment
#endif

getPreferedLang :: IO Text
getPreferedLang = do
    lang <- do
        lc_all <- lookupEnv "LC_ALL"
        lc_messages <- lookupEnv "LC_MESSAGES"
        lang <- lookupEnv "LANG"
        return $ lc_all `mplus` lc_messages `mplus` lang
    return $ maybe "en" (Text.pack . toBCP47) lang

cimatch :: Text -> Text -> Bool
cimatch w t = Text.toLower w == Text.toLower t

cimatches :: Text -> [Text] -> [Text]
cimatches w ts = dropWhile (not . cimatch w) ts

-- rfc4647 lookup of best match language tag
lookupLang :: [Text] -> [Text] -> Maybe Text
lookupLang (w:ws) tags
    | Text.null w = lookupLang ws tags
    | otherwise   = case cimatches w tags of
                        (t:_) -> Just t
                        []    -> lookupLang (reduce w:ws) tags
 where
    reduce w = Text.concat $ reverse nopriv
        where
            rparts = reverse . init $ Text.groupBy (\_ c -> c/='-') w
            nopriv = dropWhile ispriv rparts
            ispriv t = Text.length t == 2 && Text.head t == '-'

lookupLang [] tags | "" `elem` tags = Just ""
                   | otherwise      = listToMaybe $ tags


messageText :: Stanza -> IO Text
messageText msg = do
    pref <- getPreferedLang
    let m = msgLangMap (stanzaType msg)
        key = lookupLang [pref] (map fst m)
        choice = do
            k <- key
            lookup k m
    flip (maybe $ return "") choice $ \choice -> do
    let subj = fmap ("Subject: " <>) $ msgSubject choice
        ts = catMaybes [subj, msgBody choice]
    return $ Text.intercalate "\n\n" ts

crlf :: Text -> Text
crlf t = Text.unlines $ map cr (Text.lines t)
 where
    cr t | Text.last t == '\r'  = t
         | otherwise            = t <> "\r"

deliverTerminalMessage ::
    forall t t1. t -> Text -> t1 -> Stanza -> IO Bool
deliverTerminalMessage cw tty utmp msg = do
    mode <- fmap fileMode (getFileStatus $ Text.unpack tty)
    let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w
    if not mesgy then return False else do
    text <- do
        t <- messageText msg
        return $ Text.unpack
            $ case stanzaFrom msg of
                Just from -> "\r\n" <> from <> " says...\r\n" <> crlf t <> "\r\n"
                Nothing -> crlf t <> "\r\n"
    writeFile (Text.unpack tty) text
    return True -- return True if a message was delivered

main = do
    args <- getArgs
    let mas = (,) <$> listToMaybe args <*> listToMaybe (drop 1 args)
    flip (maybe $ putStrLn "pwrite user tty") mas $ \(usr,tty) -> do
    bod <- Text.getContents
    stanza <- makeMessage "jabber:client" "nobody" (Text.pack usr) bod
    b <- deliverTerminalMessage () (Text.pack tty) () stanza
    when b $ putStrLn "delivered."
    return ()