content: {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, RecordWildCards #-}
  module Main where
  
  import Data.Functor
  import Control.Monad
  import Control.Concurrent
  import Control.Concurrent.STM
  import Control.Exception (finally)
  import qualified Data.ByteString.Lazy.Char8 as B
  import qualified Data.Text as T
  import System.Console.CmdArgs.Implicit hiding (name)
  import System.Directory
  import System.IO
  
  import Resources
  import Serial
  import MockSerial
  import Serialization
  import SyncTimer
  import SimpleSockets
  
  data Args = Args { device :: String
                   , baud   :: Int
                   , socket :: FilePath
                   , mock   :: Bool
                   } deriving (Show, Data, Typeable)
  
  synopsis defSockPath =
    Args { device = def &= argPos 0 &= typ "DEVICE"
         , baud = 0 &= help "Baud rate on serial port (required if not in mock mode)"
         , socket = defSockPath &= typFile &=
                    help ("UNIX domain socket to listen. Default: " ++ defSockPath)
         , mock = False &= help "Use file or named pipe instead of \
                                \real serial hardware. If baud rate is \
                                \set, it emulates limited throughput, \
                                \too."
         }
    &= program "kryptoradio-encoder"
    &= summary "Kryptoradio Encoder v0.0.1"
    &= help "Listens to given HTTP port and sends commands to \
            \serial port connected to DVB encoder."
  
  main = do
    defSockPath <- getAppUserDataDirectory "kryptoradio-encoder"
    Args{..} <- cmdArgs $ synopsis defSockPath
    when (not mock && baud == 0) $ error "Baud rate is not set. See --help"
    conf <- newConf rawResources
    timer <- newSyncTimer
    (serialClose,writeSerial) <- if mock
                                 then openMockSerialOut device baud
                                 else openSerialOutRaw device baud
    -- Prepare socket dir
    putStrLn $ "Listening to " ++ socket
    createDirectoryIfMissing False socket
    threads <- flip mapM (resources conf) $ \r ->
      foreverAccept (app r timer) $ socket ++ "/" ++ T.unpack (name r)
    -- Start serial traffic handler in main thread. On shutdown, give
    -- 100ms for thread clean-up.
    finally
      (serializator timer (priorityTake $ resources conf) writeSerial (syncPacket conf))
      (mapM_ killThread threads >> threadDelay 100000)
  
  -- |Main app for handling incoming connection to a handle.
  app :: Resource -> SyncAct -> Handle -> IO ()
  app res timer h = do
    hSetBuffering h NoBuffering
    B.hPut h "R"
    forkIO $ foreverSync timer $ B.hPut h "S"
    forever $ handleMsg res h
  
  -- |Handle single message. Returns after delivery or deletion.
  handleMsg :: Resource -> Handle -> IO ()
  handleMsg r h = do
    -- Take given number of bytes
    len <- hGetLine h
    packet <- case readMaybe (removeD len) of
      Just n -> B.hGet h n
      _ -> do
        B.hPut h "E"
        fail "Not an integer"
  
    -- Write it to underlying worker
    atomically $ putTMVar (var r) packet
  
    -- Wait for delivery
    cmdVar <- newEmptyTMVarIO
    thread <- forkIO $ B.hGet h 1 >>= atomically . putTMVar cmdVar
    delivered <- atomically $ do
      cmd <- tryTakeTMVar cmdVar
      del <- tryReadTMVar $ var r
      case (cmd,del) of
        (_,Nothing) -> return True
        (Just "D",_) -> do
          takeTMVar $ var r
          return False
        _ -> retry
    killThread thread
  
    -- Take action
    B.hPut h $ if delivered then "R" else "D"
  
  -- |Like `read` but returns Nothing instead of an error if parsing
  -- fails. Is here becauses function `readMaybe` was introduced in
  -- base-4.6 which is not yet mainstream.
  readMaybe x = case readsPrec 0 x of
    [(a,"")] -> Just a
    _        -> Nothing
  
  -- |Strips D from beginning. Sometimes data feeder is too slow and
  -- does send D after it has read R from input. This is not fatal but
  -- messes integer parser without this.
  removeD :: String -> String
  removeD ('D':xs) = xs
  removeD xs = xs
  