content: {-# LANGUAGE OverloadedStrings #-}
  module Main where
  
  import Control.Monad.Trans
  import Control.Monad.Reader
  
  import Data.Maybe
  import Data.Either
  
  import Classifier
  import StrokeSample
  import Strokes
  import qualified Data.Aeson as JSON
  import JSON.Strokes
  import JSON.Results
  import Control.Concurrent.STM
  import Control.Exception
  import System.IO.Error
  import System.Environment
  import qualified Data.ByteString.Char8 as B
  import qualified Data.ByteString.Lazy.Char8 as BL
  
  import Network.HTTP.Types (badRequest400)
  
  import Web.Scotty
  
  port = 3000
  
  cK = 50
  classifier = newClassifier cK
  
  alpha = 2*pi*15/360
  
  sanitize :: Strokes -> Strokes
  sanitize = (map (dominant alpha
                  .unduplicate
                  .redistribute 10
                  .aspectrefit (Point (0,0), Point (1,1))
                  .smooth
                  .unduplicate)
                  ).limit 10
  
  process :: Strokes -> Strokes
  process = sanitize
  
  -- validate there are no empty strokes
  validate :: Either String Strokes -> Either String Strokes
  validate (Left s) = Left s
  validate (Right s) | ((not.null) s) && (all (not.null) s) = Right s
  validate _ = Left "Illegal stroke."
  
  jsonerror :: String -> ActionM ()
  jsonerror e = do
    status Network.HTTP.Types.badRequest400
    json $ JSON.object [("error", JSON.toJSON e)]
  
  jsonmessage :: String -> ActionM ()
  jsonmessage m = json $ JSON.object [("message", JSON.toJSON m)]
  
  classify :: Classifier StrokeSample -> Either String Strokes -> ActionM ()
  classify c d =
    either
      (\e -> do
        jsonerror e)
      (\strokes -> do
        res <- liftIO $ classifyWithClassifier c (newStrokeSample (process strokes))
        json res)
      d -- comes out as Either String Strokes
  
  train :: Classifier StrokeSample -> Either String Strokes -> String -> ActionM ()
  train c d id = either
    (\e -> jsonerror e)
    (\strokes -> do
      let processed = (process strokes)
      liftIO $ print $ show processed -- FIXME workaround for strict evaluation
      liftIO $ trainClassifier c id (newStrokeSample processed)
      jsonmessage "Sample was successfully trained.")
    d
  
  main = do
    putStrLn "hs-classifier at http://localhost:3000"
    c <- classifier
  
    loaded <- loadSuccess c
    case loaded of
      True -> putStrLn "Snapshot loaded."
      False -> putStrLn "No snapshot found."
  
    scotty port $ do
  
      get "/" $ do
        json $ JSON.object [("server", "Nöt Betty :("), ("version", "0.0.2")]
  
      post "/classify" $ do
        d <- body
        let eitherJson = validate $ JSON.eitherDecode $ d
        classify c eitherJson
  
      post "/train/:id" $ do
        id <- param "id"
        d <- body
        jsonerror "fu"
        let eitherJson = validate $ JSON.eitherDecode $ d
        train c eitherJson id
  
      enableSnapshot <- liftIO $ tryJust (guard . isDoesNotExistError) $ getEnv "ENABLESNAPSHOT"
      when (isRight enableSnapshot) $ do
  
        post "/save-snapshot" $ do
          liftIO $ snapshot c
          jsonmessage "Snapshotted."
  
        post "/load-snapshot" $ do
          success <- liftIO $ loadSuccess c
          case success of
            True -> jsonmessage "Loaded"
            False -> jsonmessage "No. Just no."
  
  snapshotJsonFile = "snapshot.json"
  
  snapshot :: Classifier StrokeSample -> IO ()
  snapshot c = do
    snapshot <- atomically $ (readTVar $ samples c)
    BL.writeFile snapshotJsonFile $ JSON.encode snapshot
  
  load :: Classifier StrokeSample -> IO ()
  load c = do
    jsonString <- BL.readFile snapshotJsonFile
    case (JSON.decode jsonString) of
      Nothing -> return ()
      Just snapshot -> atomically $ (writeTVar (samples c) snapshot)
  
  loadSuccess c = load c >> return True `catch` handle where
    handle :: IOError -> IO Bool
    handle e
      | isDoesNotExistError e = return False
      | otherwise = ioError e
  