content: {-# LANGUAGE OverloadedStrings #-}
  
  -- | Generate dynamic GIF streams and provide them on an HTTP server.
  module GifStream (
    -- Functions
    server,
    -- Types
    RGB,
    Frame,
    FrameSignal,
    Logic
    )
    where
  
  import System.IO
  
  import Network.Socket
  import Network.Socket.ByteString (sendAll)
  
  import Control.Monad
  import Control.Concurrent
  
  import Data.IORef
  
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Char8() -- for OverloadedStrings
  
  type RGB = (Int,Int,Int) -- ^ Values in [0..3]
  type Frame = [[RGB]]
  type FrameSignal = MSignal Frame
  type Logic = IO () -> IO Char -> (Frame -> IO ()) -> IO ()
  
  -- | Run an HTTP server that delivers a continuing stream of a GIF to every
  --   incoming connections. A logic function is called to generate the GIF
  --   frames.
  server :: PortNumber -> Int -> Logic -> IO ()
  server port delay logic = withSocketsDo $ do
    hSetBuffering stdin NoBuffering
    sock <- socket AF_INET Stream 0
    setSocketOption sock ReuseAddr 1
    bind sock (SockAddrInet port 0)
    listen sock 10 -- Allow 10 concurrent users
  
    putStrLn $ "Listening on http://127.0.0.1:" ++ show port ++ "/"
  
    wait <- getMetronome delay
    getAction <- inputGetter
    frameSignal <- newMSignal
  
    forkIO $ loop delay frameSignal sock
  
    logic wait getAction $ sendMSignal frameSignal
  
  -- | Wait for incoming connections and start delivering a GIF to them
  loop :: Int -> FrameSignal -> Socket -> IO ()
  loop delay frameSignal sock = do
    (conn, _) <- accept sock
  
    forkIO $ body conn
    loop delay frameSignal sock
  
    where -- lower delay in GIF to force browser to actually show the gif we send
      body c = do
        f <- receiveMSignal frameSignal
        sendAll c $ msg $ initialFrame (delay `div` 20000) f
        nextFrame c
  
      nextFrame c = do
        f <- receiveMSignal frameSignal
        sendAll c $ frame (delay `div` 20000) f
        nextFrame c
  
      msg content = B.intercalate "\r\n"
        [ "HTTP/1.0 200 OK"
        , "Server: gifstream/0.1"
        , "Content-Type: image/gif"
        , "Content-Transfer-Encoding: binary"
        , ""
        , content
        ]
  
  -- | Get a function that waits for the specified time whenever it's called
  getMetronome :: Int -> IO (IO ())
  getMetronome delay = do
      var <- newMVar ()
      forkIO $ forever $ do
          threadDelay delay
          putMVar var ()
      return $ takeMVar var
  
  -- | Get a function that returns the last key pressed whenever it's called
  inputGetter :: IO (IO Char)
  inputGetter = do
      inputRef <- newIORef 'd' -- Default input
      forkIO $ forever $ do
          c <- getChar
          writeIORef inputRef c
      return $ readIORef inputRef
  
  -- | Create the initial frame of a GIF. Note that this frame determines the size of the GIF.
  initialFrame :: Int -> Frame -> B.ByteString
  initialFrame delay img = B.concat
    [ "GIF89a"
    , number w, number h, gctInfo, bgColor, aspect -- logical screen descriptor
    , realCT, dummyCT                              -- color table
    , "!\255\vNETSCAPE2.0\ETX\SOH\NUL\NUL\NUL"     -- application extension
    , frame delay img
    ]
    where
      w = length $ head img
      h = length img
      gctInfo = B.singleton 0xf6
      bgColor = smallNumber 127
      aspect  = "\NUL"
  
      realCT  = B.concat $ map B.pack [[r,g,b] | r <- colors, g <- colors, b <- colors]
      colors  = [0,64,128,255]
      dummyCT = B.concat $ replicate 64 $ B.pack [255,255,255]
  
  -- | Create the next frame in a GIF
  frame :: Int -> Frame -> B.ByteString
  frame delay img = B.concat
    [ "!\249\EOT\b", number delay, "\255", "\NUL"  -- graphic control extension
    , ",", yPos, xPos, number w, number h, localCT -- image descriptor
    , lzwMinSize, imageData, "\NUL"                -- image
    ]
    where
      w = length $ head img
      h = length img
      yPos = number 0
      xPos = number 0
      localCT = "\NUL"
  
      lzwMinSize = B.singleton 0x07
      imageData = B.concat $ map (B.concat . mapLine) img
  
      mapLine x
        | null ys   = z
        | otherwise = z ++ mapLine ys
        where (y,ys) = splitAt 126 x
              z = [ bytesToFollow, clear
                  , B.pack $ map (\(r,g,b) -> fromIntegral $ 16*r+4*g+b) y
                  ]
              bytesToFollow = smallNumber $ length y + 1
              clear = B.singleton 0x80
  
  -- | Close the GIF file
  finalize :: B.ByteString
  finalize = B.concat [bytesToFollow, stop, "\NUL", ";"]
    where
      bytesToFollow = smallNumber 1
      stop = B.singleton 0x81
  
  -- | Convert a number to one Byte
  smallNumber :: Int -> B.ByteString
  smallNumber x = B.singleton $ fromIntegral $ x `mod` 256
  
  -- | Convert a number to two Bytes
  number :: Int -> B.ByteString
  number x = B.pack $ map fromIntegral [x `mod` 256, x `div` 256]
  
  -- | A Module for broadcast signalling between threads.
  -- By Joachim Breitner
  
  -- | MSignal is an opaque data type
  newtype MSignal a = MS (MVar a)
  
  -- | Creates a new MSignal object. This can be used to send and receive signals, possibly containing some data. If you do not want to transmit data, use @'MSignal' ()@
  newMSignal :: IO (MSignal a)
  newMSignal = MS `liftM` newEmptyMVar
  
  -- | Sends new data to all threads currently running 'receiveMSignal'
  sendMSignal :: MSignal a -> a -> IO ()
  sendMSignal (MS mv) v = do
    forkIO $ takeMVar mv >> return () -- Cleanup afterwards
    putMVar mv v
  
  -- | Blocks until another threads sends data using 'sendMSignal'. It then returns the sent data.
  receiveMSignal :: MSignal a -> IO a
  receiveMSignal (MS mv) = readMVar mv
  