memis-0.1.1: src/Main.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
import Control.Arrow
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Class
import Data.Aeson
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.UTF8 as L
import qualified Data.ByteString.UTF8 as B
import Data.Char
import qualified Data.HashMap.Strict as M
import Data.List hiding (find)
import Data.List.Split
import Data.Maybe
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types
import Network.Mime
import Network.Wai
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Static
import Safe
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.FilePath.Find
import System.Process (proc,readProcessWithExitCode)
import System.Process.ByteString.Lazy hiding (readProcessWithExitCode)
import Text.Blaze.Html.Renderer.Utf8
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Printf
import Text.Read (readEither)
import Text.Regex
import Text.Regex.TDFA
import Web.Frank
import Web.Simple hiding (hoistEither,body)
port = 8081 :: Int
targetD = "/home/data/schriftverkehr/aktuell"
sourceD = "/home/data/schriftverkehr/Unsortiert"
javascript x = H.script H.! A.src x $ mempty
stylesheet x = H.link H.! A.rel "stylesheet" H.! A.type_ "text/css" H.! A.href x
app2 :: String -> String -> Application
app2 target source = controllerApp () $ do
get "/" $ do
dirs <- lift $ targetDirs target
img <- lift (images source)
respond $ okHtml $ body dirs $ H.unsafeByteString $ mconcat
["var imgs = ", L.toStrict $ encode
$ (\x -> M.fromList [("id"::String,x)]) <$> img ]
get "/img" $ do
f :: String <- queryParam' "id"
size :: Maybe String <- queryParam "size"
let scale size = do
(_,stdout,_) <- lift $ readCreateProcessWithExitCode
(proc "/usr/bin/convert" [f,"-filter","Lagrange"
,"-resize",size,"-"]) ""
respond $ ok (defContentType f) stdout
if source `isPrefixOf` f then maybe (respond $ file f) scale size
else error $ printf "%s not in %s" f source
post "/apply" $ do
(params,_) <- parseForm
let a = either (\x -> error $ "decode failed: " ++ x) id
$ eitherDecodeStrict' $ lookupJust "imgs" params :: [Action]
runIt x = E.handle (\e-> return $ show (e::E.SomeException)) $
x (target,source)
respond . okHtml . mconcat . fmap L.fromString =<< lift (mapM runIt a)
get "/mkdir" $ do
name :: String <- queryParam' "name"
resp <- lift $ E.handle
(\e->return $ L.fromString $ show (e::E.SomeException)) $ do
createDirectoryIfMissing True $ target </> name
renderHtml <$> targetDirs target
respond . okHtml $ resp
type Action = (String,String) -> IO String
instance FromJSON Action where
parseJSON (Object v) = do
old <- v .: "id"
let fileO = takeFileName old
convertDate "delete" = Right $ "delete_" ++ fileO
convertDate s = (++ takeExtension old) . intercalate "-"
<$> mapM form (reverse . splitOn "." $ s)
form d = printf "%02i" <$> left (printf "date '%s': %s" d :: String -> String)
(readEither d :: Either String Int)
file <- maybe (Right fileO) convertDate <$> v .:? "date"
dir <- maybe (return $ takeDirectory old) (.: "id") =<< v .:? "dir"
angle <- v .:? "angle"
return $ \(target,source) -> do
msg <- rotate old angle
let rename f = if dir </> f == old then return "" else do
new <- (dir </>) <$> getUnusedFilename [target,source] f
exis <- doesFileExist new
when (exis || not (target `isPrefixOf` new || source `isPrefixOf` new)) $
error $ "something went wrong: " ++ show (old,dir,f,new)
renameFile old new
return $ printf "%s -> %s\n" old new
rename :: String -> IO String
return . (msg ++) =<< do
either (return . printf "Error handling %s: %s\n" old) rename file
rotate :: String -> Maybe Int -> IO String
rotate _ Nothing = pure ""
rotate f (Just angle) = g <$> readProcessWithExitCode
"/usr/bin/gm" ["mogrify","-rotate", show angle, f] ""
where g (ExitSuccess,_,_) = printf "Rotated by %s by %d degrees\n" f angle
g (_,_,err) = err
getUnusedFilename dirs f = do
l <- concat <$> forM dirs (find always $ fileType ==? RegularFile)
return . r . succ . headDef 0 . sortBy (flip compare) . (g =<<) $ l
where core [] = [takeBaseName f, "" , takeExtension f]
core x = tail x
[b,_,e] = core $ m f
m = matches "(.*)_([0-9]+)(\\.[^.]+)?"
r c = printf "%s_%03i%s" b c e :: String
g s = case m (takeFileName s) of
[_,b2,c,e2] -> if b2 /= b || e2 /= e then []
else [read c :: Int]
[] -> []
matches r s = getAllTextSubmatches $ (s::String) =~ (r:: String) :: [String]
body dirs script =renderHtml $ H.docTypeHtml $ do
H.head $ do
H.meta H.! A.charset "UTF-8"
stylesheet "//ajax.googleapis.com/ajax/libs/jqueryui/1.11.4/themes/smoothness/jquery-ui.css"
stylesheet "style.css"
javascript "//ajax.googleapis.com/ajax/libs/jquery/2.2.2/jquery.min.js"
javascript "//ajax.googleapis.com/ajax/libs/jqueryui/1.11.4/jquery-ui.min.js"
H.script script
javascript "script.js"
H.body $ do
H.span H.! A.id "largeSpan" $ do
H.div ""
H.span H.! A.id "input" $ ""
H.h4 ""
H.span H.! A.id "imgSpan" $ ""
H.span H.! A.id "large" H.! A.class_ "imgBorder" $ ""
H.span H.! A.id "dirs" $ do
H.h4 $ H.preEscapedString " "
dirs
H.span H.! A.id "help" $ do
H.h4 "Key Bindings"
H.table $ mapM_ (\(a, b) -> H.tr $ H.td a >> H.td b)
[("[Left]","Previous Image")
,("[Right]","Next Image")
,("[Home]","First Image")
,("[End]","Last Image")
,("[Shift + Left]","Move image to the previous location in the list")
,("[Shift + Right]","Move image to the next location in the list")
,("[Ctrl + <Arrow>]","Indicate Up-Direction of image and goto next")
,("[m]","Create directory")
,("[Enter]","Use date from input field and goto next image")
,("[Backspace]","Clear date input field")
,("[Delete]","Clear date")
,("[0-9],[space]","Enter date in format: 'day month' or 'day month year'")
,("[d]","Mark image for deletion")
]
H.span H.! A.id "help" $ do
H.h4 $ H.a H.! A.href "?" H.! A.onclick "return applyChanges();" $ "Apply changes"
defContentType p = mimeByExt defaultMimeMap defaultMimeType $ T.pack p
file p = responseFile
status200 [("Content-Type", defContentType p)]
p Nothing
a' =~? b = do
a <- a'
return ( a =~ (b :: String) :: Bool)
targetDirs = fmap (toH . tC) . getDirs
toH :: [T] -> H.Html
toH [] = return ()
toH d = H.ul $ forM_ d $ \(T x cs) ->
H.li H.! A.id (fromString x) $ do
H.span $ H.string $ takeFileName x
toH cs
getDirs dir = do
cs <- filter (/= dir) . sort
<$> find (depth ==? 0) (fileType ==? Directory) dir
-- print cs
return . T dir =<< mapM getDirs cs
images dir = filter (/= dir) . sort
<$> find (depth ==? 0) ((fmap toLower <$> extension) =~? "\\.(jpg|jpeg|png)"
&&? (fileName /~? "delete_*") ) dir
data T = T { tP :: FilePath,
tC :: [T]} deriving Show
main :: IO ()
main = do
a <- getArgs
cur <- getCurrentDirectory
unless (length a == 2) $ do
putStrLn "usage:\n\n\tmemis [source folder] [target folder]"
exitFailure
let [s,t] = a
printf "Source: %s\nTarget: %s\nhttp://localhost:%d\n" s t port
run port
. logStdoutDev
. staticPolicy (addBase $ cur </> "static")
$ app2 t s