{-# 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 + ]","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