{-# LANGUAGE TemplateHaskell, QuasiQuotes, NamedFieldPuns #-}


module CodeMushu.Repo where


import CodeMushu.Env
import Prelude ()

import System.Process
import Data.List hiding (length)

import qualified Data.ByteString.Char8 as B

import Control.Monad hiding (join)
import System.Posix hiding (sleep)

import Data.Map (Map)

import System.FilePath

import Database.HDBC
import Database.HDBC.Sqlite3

import MPS.TH
import MPS.Extra
import MPSUTF8 (mkdir_p, rm_rf)
import System.Directory

import Control.Concurrent.STM
import GHC.IO.Exception 

import qualified Prelude as P

import CodeMushu.Project

import Network.Curl hiding (content)

is_text :: String -> IO Bool
is_text x = do
  r <- readProcess "file" ["-b", x] ""

  return - "text" `isInfixOf` r

is_image :: String -> Bool
is_image = 
  let image_extensions = [".png", ".jpg"]
  in

  takeExtension > belongs_to image_extensions

not_too_big :: String -> IO Bool
not_too_big = getFileStatus >=> fileSize > (<= limit) > return
  where
    limit = _500k
    _1m = 1000000
    _500k = 500000

find_source :: StatusCallback -> String -> IO ([String], [String])
find_source cb path = do
  cb - DBStage - DBAnalysing
  
  r <- readProcess "find" [path] ""

  let clean_files = reject (splitPath > has ".svn/")
      paths = r.lines .clean_files

  files <- paths.filterM (getFileStatus >=> isRegularFile > return)
  dirs <- paths.filterM (getFileStatus >=> isDirectory > return)
  
  fs <- files.filterM is_text >>= filterM not_too_big

  let imgs = files.filter is_image

  return - (dirs, fs)

load_code :: String -> String -> IO Code
load_code _ [] = error "code path can not be empty"
load_code base x = do
  let relative_path = makeRelative base x
  content <- B.readFile x ^ (B.unpack > b2u)

  let tokens = relative_path.splitPath
      path = relative_path
      depth = length tokens .from_i
      parent = if depth.is 1 then "/" else tokens.init.concat

  filesize <- getFileStatus x ^ fileSize ^ from_i

  return - def
    {
      path
    , parent
    , depth
    , filesize
    , content
    }

load_dir :: String -> String -> IO Code
load_dir _ [] = error "code path can not be empty"
load_dir base x = do
  let relative_path = makeRelative base x

  let tokens = relative_path.splitPath
      path = relative_path
      depth = length tokens .from_i
      parent = if depth.is 1 then "/" else tokens.init.concat

  return - def
    {
      path
    , parent
    , depth
    , is_directory = 1
    }

insert_code :: (IConnection d) => d -> Code -> IO ()
insert_code db code = do
  let { vals = 

    [ toSql - code.path
    , toSql - code.parent
    , toSql - code.depth
    , toSql - code.filesize
    , toSql - code.content
    , toSql - code.is_directory
    ]

    }


  -- withTransaction db - \d -> run d insert_sql vals
  run db insert_sql vals
  
  -- log - "inserted " + code.path

  -- [[uid]] <- quickQuery db "select last_insert_rowid()" []

  -- return (fromSql uid) 

  return ()
  

insert_code_from_path :: (IConnection d) => d -> String -> String -> IO ()
insert_code_from_path db base x = load_code base x >>= insert_code db

insert_dir_from_path :: (IConnection d) => d -> String -> String -> IO ()
insert_dir_from_path db base x = load_dir base x >>= insert_code db

init_db :: StatusCallback -> Project -> IO Connection
init_db cb p = do
  cb - DBStage - DBInit
  mkdir_p - p.project_db_path

  db <- handleSqlError - connectSqlite3 - p.project_db_file
  create_table_if_missing db

  return db

insert_project :: StatusCallback -> Connection -> Project -> IO ()
insert_project cb db p = do
  (dirs, source_files) <- find_source cb (p.project_source_path)
  
  dirs.mapM_ (insert_dir_from_path db (p.project_source_path))
  
  let total = source_files.length
  
  int_counter_ref <- newIORef 0
  
  source_files.indexed.mapM_ ( \(i, path) -> do
    let progress = i.realToFrac P./ total.realToFrac
    
    int_counter <- readIORef int_counter_ref
    
    let int_percent = floor - progress * 100
    
    when (int_counter P.< int_percent) - do
      cb - DBStage - DBImporting int_percent
      writeIORef int_counter_ref int_percent
  
    insert_code_from_path db (p.project_source_path) path
    )

create_db :: StatusCallback -> Project -> IO ()
create_db cb p = do
  db <- init_db cb p

  insert_project cb db p
  
  index_db cb db p
  
  commit db
  
  release_db cb db p

  return ()

index_db :: StatusCallback -> Connection -> Project -> IO ()
index_db cb db _ = do
  cb - DBStage - DBIndexing
  sql_indecies.lines.reject null.mapM_ (\sql_index -> run db sql_index [])
  commit db


release_db :: StatusCallback -> Connection -> Project -> IO ()
release_db cb db _ = do
  cb - DBStage - DBComplete
  disconnect db



create_table_if_missing :: (IConnection a) => a -> IO ()
create_table_if_missing db = do
  tables <- handleSqlError $ getTables db
  when (not - "code" `elem` tables) - handleSqlError - do
    run db sql_schema []
    commit db

-- repo / project_id / [src|db] | public/repo/project_id.sqlite
init_project :: Integer -> String -> Repo -> IO Project
init_project job_id project_url repo = do
  let project_id = job_id
  let project_name = project_url.takeFileName

  return - def 
    {
      project_name
    , project_id
    , repo
    , project_url
    }

make_project_id :: IO String
make_project_id = now_in_micro_seconds ^ show

-- get_project_name_from_url = split "/" .last
unpack_git_repo :: StatusCallback -> Project -> IO ExitCode
unpack_git_repo cb p = do
  mkdir_p - p.project_root_path

  cb - UnpackStage - Unpacking
  exit_code <- rawSystem "git" ["clone", "-q", p.project_url, p.project_source_path]

  when ( exit_code .is ExitSuccess ) - do
    rm_rf - p.project_source_path / ".git"

  return exit_code

unpack_hg_repo :: StatusCallback -> Project -> IO ExitCode
unpack_hg_repo cb p = do
  mkdir_p - p.project_root_path

  cb - UnpackStage - Unpacking
  exit_code <- rawSystem "hg" ["clone", p.project_url, p.project_source_path]

  when ( exit_code .is ExitSuccess ) - do
    rm_rf - p.project_source_path / ".hg"

  return exit_code

unpack_darcs_repo :: StatusCallback -> Project -> IO ExitCode
unpack_darcs_repo cb p = do
  mkdir_p - p.project_root_path

  cb - UnpackStage - Unpacking
  exit_code <- rawSystem "darcs" ["get", "--lazy", p.project_url, p.project_source_path]

  
  log - "exit code: " + show exit_code

  when ( exit_code .is ExitSuccess ) - do
    rm_rf - p.project_source_path / "_darcs"

  return exit_code

validate_repo_url :: String -> IO (Maybe String)
validate_repo_url url = do
  (r, xs) <- curlHead url [CurlFollowLocation True]
  
  return - if r.null.not
    then
      case xs.reverse.lookup "Content-Length" >>= readMay of
        Just i ->
          -- archive less then 50 MB is valid
          if i `div` (1024 * 1024) <= 50
            then
              Nothing
            else
              Just "repo too big"
        Nothing -> Nothing
    else
      Just "invalid url"
  

with_valid_repo :: StatusCallback -> String -> IO ExitCode -> IO ExitCode
with_valid_repo cb url io = do
  status <- validate_repo_url - url
  case status of
    Nothing -> do
      io
      
    Just err -> do
      cb - Failed - Exception err
      return - ExitFailure 0
  

unpack_raw_repo :: StatusCallback -> Project -> IO ExitCode
unpack_raw_repo cb p = do
  mkdir_p - p.project_source_path

  cb - UnpackStage - Unpacking
  
  with_valid_repo cb (p.project_url) - do
    exit_code <- rawSystem "wget" [p.project_url, "--directory-prefix", p.project_source_path]
    log - "exit code: " + show exit_code
    return exit_code

unpack_archive_repo :: StatusCallback -> Project -> IO ExitCode
unpack_archive_repo cb p = do
  mkdir_p - p.project_source_path

  cb - UnpackStage - Unpacking
  
  with_valid_repo cb (p.project_url) - do
    exit_code <- rawSystem "wget" [p.project_url, "--directory-prefix", p.project_source_path]
    downloads <- ls - p.project_source_path
    case downloads of
      [] -> log "could not found downloaded archives"
      x:_ -> do
        system - "cd " + p.project_source_path + "; unp " + x
        removeFile - p.project_source_path / x

    log - "exit code: " + show exit_code
    return exit_code

unpack_svn_repo :: StatusCallback -> Project -> IO ExitCode
unpack_svn_repo cb p = do
  mkdir_p - p.project_root_path

  cb - UnpackStage - Unpacking
  exit_code <- rawSystem "svn" ["co", "--non-interactive", "-q", p.project_url, p.project_source_path]

  
  log - "exit code: " + show exit_code

  return exit_code


unpack_repo :: Repo -> StatusCallback -> Project -> IO ExitCode
unpack_repo Git = unpack_git_repo
unpack_repo Darcs = unpack_darcs_repo
unpack_repo Raw = unpack_raw_repo
unpack_repo Archive = unpack_archive_repo
unpack_repo SVN = unpack_svn_repo
unpack_repo Hg = unpack_hg_repo

bounce_repo :: StatusCallback -> Project -> IO ()
bounce_repo cb p = do
  cb Bouncing
  copyFile (p.project_db_file) (p.project_bounce_file)

cleanup_repo :: StatusCallback -> Project -> IO ()
cleanup_repo cb p = do
  cb Cleanup
  
  -- hack
  -- fork - do
  --   sleep 10
  
  rm_rf - p.project_root_path

create_project :: StatusCallback -> Integer -> Repo -> String -> IO ()
create_project cb job_id repo x = do
  p <- init_project job_id x repo
  
  exit_code <- return_after 30 - unpack_repo repo cb p

  case exit_code of
    ExitSuccess -> do
      cb - UnpackStage - UnpackComplete
      create_db cb p
      bounce_repo cb p
      cleanup_repo cb p

      cb - Completed p

    ExitFailure error_code -> do
      cleanup_repo cb p

      cb - Failed FailedToFetchRepo




-- sql_schema :: String
sql_schema = [$here|


create table code (
    id INTEGER PRIMARY KEY
  , path TEXT
  , parent TEXT
  , depth INTEGER
  , filesize INTEGER
  , content TEXT
  , is_directory INTEGER
);


|]

sql_indecies = [$here|

create index path_index on code (path);
create index parent_index on code (parent);
create index depth_index on code (depth);
create index is_directory_index on code (is_directory);

|]


insert_sql = [$here|

INSERT INTO code(path, parent, depth, filesize, content, is_directory) VALUES(?, ?, ?, ?, ?, ?)

|]