    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE ViewPatterns   #-}

    -- | A server for scrobbling, based upon the Audioscrobbler Realtime
    -- Submission protocol v1.2
    -- <http://www.audioscrobbler.net/development/protocol/>

    module Scrobble.Server
      (startScrobbleServer
      ,module Scrobble.Types)
      where

    import           Scrobble.Types

    import           Control.Applicative hiding (optional)
    import           Control.Concurrent
    import           Control.Exception
    import           Control.Monad
    import           Data.Char
    import           Data.List
    import           Data.Time
    import           Network
    import           Network.URL
    import           Numeric
    import           Prelude             hiding (catch)
    import           System.IO
    import           System.Locale

    --------------------------------------------------------------------------------
    -- Server

    -- | Start a scrobbling server.
    startScrobbleServer :: Config -> Handlers -> IO ()
    startScrobbleServer cfg handlers = do
      hSetBuffering stdout NoBuffering
      clients <- newMVar []
      listener <- listenOn (PortNumber (cfgPort cfg))
      expire <- forkIO $ expireClients handlers cfg clients
      flip finally (do sClose listener; killThread expire) $ forever $ do
        (h,_,_) <- accept listener
        forkIO $ do
          hSetBuffering h NoBuffering
          headers <- getHeaders h
          case requestMethod headers of
            Just ("GET",url_params -> params) -> handleInit cfg handlers h clients params
            Just ("POST",url) -> do
              rest <- hGetContents h
              case requestBody headers rest of
                Nothing -> return ()
                Just body -> dispatch handlers h clients url body
            _ -> return ()
          hClose h

    -- | Expire client sessions after inactivity.
    expireClients :: Handlers -> Config -> MVar [Session] -> IO ()
    expireClients handlers cfg clients = forever $ do
      threadDelay (1000 * 1000 * 60)
      now <- getCurrentTime
      modifyMVar_ clients $ filterM $ \client -> do
        let expired = diffUTCTime now (sesTimestamp client) > cfgExpire cfg
        when expired $ handleExpire handlers client
        return (not expired)

    -- | Handle initial handshake.
    handleInit :: Config -> Handlers -> Handle -> MVar [Session] -> [(String,String)] -> IO ()
    handleInit cfg handlers h clients params =
      case params of
        (makeSession -> Just sess) -> do
          handleHandshake handlers sess
          modifyMVar_ clients (return . (sess :))
          reply h [show OK
                  ,sesToken sess
                  ,selfurl "nowplaying"
                  ,selfurl "submit"]
        _ -> reply h [show BADAUTH]

      where selfurl x = "http://" ++ cfgHost cfg ++ ":" ++ show (cfgPort cfg) ++ "/" ++ x

    -- | Dispatch on commands.
    dispatch :: Handlers -> Handle -> MVar [Session] -> URL -> String -> IO ()
    dispatch handlers h clients url body =
      case parsePost body of
        Nothing -> error "Unable to parse POST body."
        Just params ->
          withSession h clients params $ \sess ->
            case url_path url of
              "nowplaying" -> handleNow handlers h sess params
              "submit" -> handleSubmit handlers h sess params
              _ -> error $ "Unknown URL: " ++ url_path url

    -- | Look up the session and do something with it.
    withSession ::  Handle -> MVar [Session] -> [(String,String)] -> (Session -> IO ()) -> IO ()
    withSession h clients params go =
      case lookup "s" params of
        Nothing -> error "No session given."
        Just token -> do
          modifyMVar_ clients $ \sessions -> do
            case find ((==token) . sesToken) sessions of
              Nothing -> do reply h [show BADSESSION]
                            return sessions
              Just sess -> do go sess
                              now <- getCurrentTime
                              return (sess { sesTimestamp = now } :
                                      (filter ((/=token) . sesToken) sessions))

    -- | Handle now playing command.
    handleNow handlers h sess params = do
      case makeNowPlaying params of
        Nothing -> error $ "Invalid now playing notification: " ++ show params
        Just np -> do handleNowPlaying handlers sess np
                      reply h [show OK]

    -- | Handle submit command.
    handleSubmit handlers h sess params = do
      case makeSubmissions params of
        Nothing -> error $ "Unable to parse submissions: " ++ show params
        Just subs -> do
          ok <- handleSubmissions handlers sess subs
          when ok $
            reply h [show OK]

    --------------------------------------------------------------------------------
    -- Command data structures

    -- | Make a session from a parameter set.
    makeSession :: [(String,String)] -> Maybe Session
    makeSession params =
      Session <$> bool (get "hs")
              <*> get "p"
              <*> get "c"
              <*> get "v"
              <*> get "u"
              <*> time (get "t")
              <*> get "a"
      where get k = lookup k params

    -- | Make a now-playing notification.
    makeNowPlaying :: [(String,String)] -> Maybe NowPlaying
    makeNowPlaying params =
      NowPlaying <$> get "a"
                 <*> get "t"
                 <*> optional (get "b")
                 <*> mint (get "l")
                 <*> mint (get "n")
                 <*> optional (get "m")
      where get k = lookup k params

    -- | Make a batch of track submissions.
    makeSubmissions :: [(String,String)] -> Maybe [Submission]
    makeSubmissions params =
      forM [0..length (filter (isPrefixOf "a[" . fst) params) - 1] $ \i -> do
        let get k = lookup (k ++ "[" ++ show i ++ "]") params
        Submission <$> get "a"
                   <*> get "t"
                   <*> time (get "i")
                   <*> source (get "o")
                   <*> rating (get "r")
                   <*> mint (get "l")
                   <*> optional (get "b")
                   <*> mint (get "n")
                   <*> optional (get "m")

      where source m = m >>= \s -> lookup s sources where
              sources = [("P",UserChosen)
                        ,("R",NonPersonlizedBroadcast)
                        ,("E",Personalized)
                        ,("L",LastFm)
                        ,("U",Unknown)]
            rating m = m >>= \r -> fmap Just (lookup r ratings) <|> return Nothing where
              ratings = [("L",Love),("B",Ban),("S",Skip)]

    --------------------------------------------------------------------------------
    -- Some param parsing utilities

    time m = m >>= parseTime defaultTimeLocale "%s"
    bool = fmap (=="true")
    mint m = m >>= \x -> case reads x of
      [(n,"")] -> return (Just n)
      _        -> return Nothing
    optional m = do
      v <- m
      if null v
        then return Nothing
        else return (Just v)

    --------------------------------------------------------------------------------
    -- HTTP utilities

    -- | Parse a POST request's parameters.
    parsePost :: String -> Maybe [(String, String)]
    parsePost body = fmap url_params (importURL ("http://x/x?" ++ body))

    -- | Get the request method.
    requestMethod :: [String] -> Maybe (String,URL)
    requestMethod headers =
       case words (concat (take 1 headers)) of
         [method,importURL -> Just url,_] ->
           return (method,url)
         _ -> Nothing

    -- | Get the request body.
    requestBody :: [String] -> String -> Maybe String
    requestBody headers body = do
      len <- lookup "content-length:" (map (break (==' ') . map toLower) headers)
      case readDec (unwords (words len)) of
        [(l,"")] -> return (take l body)
        _        -> Nothing

    -- | Read up to the headers.
    getHeaders :: Handle -> IO [String]
    getHeaders h = go [] where
      go ls = do
        l <- hGetLine h
        if l == "\r"
           then return (reverse ls)
           else go (l : ls)

    -- | Make a HTTP reply.
    reply :: Handle -> [String] -> IO ()
    reply h rs = hPutStrLn h resp where
      body = unlines rs
      resp = unlines ["HTTP/1.1 200 OK"
                     ,"Content-Length: " ++ show (length body)
                     ,""] ++
             body